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 }
592 cvtLit (StringL s) = do { let { s' = mkFastString s }
594 ; return $ HsString s' }
595 cvtLit (StringPrimL s) = do { let { s' = mkFastString s }
597 ; return $ HsStringPrim s' }
598 cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
599 -- cvtLit should not be called on IntegerL, RationalL
600 -- That precondition is established right here in
601 -- Convert.lhs, hence panic
603 cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName]
604 cvtPats pats = mapM cvtPat pats
606 cvtPat :: TH.Pat -> CvtM (Hs.LPat RdrName)
607 cvtPat pat = wrapL (cvtp pat)
609 cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName)
611 | overloadedLit l = do { l' <- cvtOverLit l
612 ; return (mkNPat l' Nothing) }
613 -- Not right for negative patterns;
614 -- need to think about that!
615 | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat l' }
616 cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat s' }
617 cvtp (TupP [p]) = cvtp p
618 cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void }
619 cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps; return $ ConPatIn s' (PrefixCon ps') }
620 cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
621 ; return $ ConPatIn s' (InfixCon p1' p2') }
622 cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat p' }
623 cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat p' }
624 cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
625 cvtp TH.WildP = return $ WildPat void
626 cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
627 ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
628 cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void }
629 cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' }
631 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
633 = do { s' <- vNameL s; p' <- cvtPat p
634 ; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) }
636 -----------------------------------------------------------
637 -- Types and type variables
639 cvtTvs :: [TH.TyVarBndr] -> CvtM [LHsTyVarBndr RdrName]
640 cvtTvs tvs = mapM cvt_tv tvs
642 cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
643 cvt_tv (TH.PlainTV nm)
644 = do { nm' <- tName nm
645 ; returnL $ UserTyVar nm' placeHolderKind
647 cvt_tv (TH.KindedTV nm ki)
648 = do { nm' <- tName nm
649 ; returnL $ KindedTyVar nm' (cvtKind ki)
652 cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
653 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
655 cvtPred :: TH.Pred -> CvtM (LHsPred RdrName)
656 cvtPred (TH.ClassP cla tys)
657 = do { cla' <- if isVarName cla then tName cla else tconName cla
658 ; tys' <- mapM cvtType tys
659 ; returnL $ HsClassP cla' tys'
661 cvtPred (TH.EqualP ty1 ty2)
662 = do { ty1' <- cvtType ty1
663 ; ty2' <- cvtType ty2
664 ; returnL $ HsEqualP ty1' ty2'
667 cvtPredTy :: TH.Type -> CvtM (LHsPred RdrName)
669 = do { (head, tys') <- split_ty_app ty
671 ConT tc -> do { tc' <- tconName tc; returnL $ HsClassP tc' tys' }
672 VarT tv -> do { tv' <- tName tv; returnL $ HsClassP tv' tys' }
673 _ -> failWith (ptext (sLit "Malformed predicate") <+>
674 text (TH.pprint ty)) }
676 cvtType :: TH.Type -> CvtM (LHsType RdrName)
678 = do { (head_ty, tys') <- split_ty_app ty
681 | length tys' == n -- Saturated
682 -> if n==1 then return (head tys') -- Singleton tuples treated
683 -- like nothing (ie just parens)
684 else returnL (HsTupleTy Boxed tys')
686 -> failWith (ptext (sLit "Illegal 1-tuple type constructor"))
688 -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys'
690 | [x',y'] <- tys' -> returnL (HsFunTy x' y')
691 | otherwise -> mk_apps (HsTyVar (getRdrName funTyCon)) tys'
693 | [x'] <- tys' -> returnL (HsListTy x')
694 | otherwise -> mk_apps (HsTyVar (getRdrName listTyCon)) tys'
695 VarT nm -> do { nm' <- tName nm; mk_apps (HsTyVar nm') tys' }
696 ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' }
700 -> do { tvs' <- cvtTvs tvs
701 ; cxt' <- cvtContext cxt
703 ; returnL $ mkExplicitHsForAllTy tvs' cxt' ty'
707 -> do { ty' <- cvtType ty
708 ; mk_apps (HsKindSig ty' (cvtKind ki)) tys'
711 _ -> failWith (ptext (sLit "Malformed type") <+> text (show ty))
714 mk_apps head_ty [] = returnL head_ty
715 mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
716 ; mk_apps (HsAppTy head_ty' ty) tys }
718 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
719 split_ty_app ty = go ty []
721 go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
722 go f as = return (f,as)
724 cvtKind :: TH.Kind -> Type.Kind
725 cvtKind StarK = liftedTypeKind
726 cvtKind (ArrowK k1 k2) = mkArrowKind (cvtKind k1) (cvtKind k2)
728 -----------------------------------------------------------
731 -----------------------------------------------------------
732 -- some useful things
734 overloadedLit :: Lit -> Bool
735 -- True for literals that Haskell treats as overloaded
736 overloadedLit (IntegerL _) = True
737 overloadedLit (RationalL _) = True
738 overloadedLit _ = False
741 void = placeHolderType
743 --------------------------------------------------------------------
744 -- Turning Name back into RdrName
745 --------------------------------------------------------------------
748 vNameL, cNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
749 vName, cName, tName, tconName :: TH.Name -> CvtM RdrName
751 vNameL n = wrapL (vName n)
752 vName n = cvtName OccName.varName n
754 -- Constructor function names; this is Haskell source, hence srcDataName
755 cNameL n = wrapL (cName n)
756 cName n = cvtName OccName.dataName n
758 -- Type variable names
759 tName n = cvtName OccName.tvName n
761 -- Type Constructor names
762 tconNameL n = wrapL (tconName n)
763 tconName n = cvtName OccName.tcClsName n
765 cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
766 cvtName ctxt_ns (TH.Name occ flavour)
767 | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
768 | otherwise = force rdr_name >> return rdr_name
770 occ_str = TH.occString occ
771 rdr_name = thRdrName ctxt_ns occ_str flavour
773 okOcc :: OccName.NameSpace -> String -> Bool
776 | OccName.isVarNameSpace ns = startsVarId c || startsVarSym c
777 | otherwise = startsConId c || startsConSym c || str == "[]"
779 -- Determine the name space of a name in a type
781 isVarName :: TH.Name -> Bool
782 isVarName (TH.Name occ _)
783 = case TH.occString occ of
785 (c:_) -> startsVarId c || startsVarSym c
787 badOcc :: OccName.NameSpace -> String -> SDoc
789 = ptext (sLit "Illegal") <+> pprNameSpace ctxt_ns
790 <+> ptext (sLit "name:") <+> quotes (text occ)
792 thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
793 -- This turns a Name into a RdrName
794 -- The passed-in name space tells what the context is expecting;
795 -- use it unless the TH name knows what name-space it comes
796 -- from, in which case use the latter
798 -- ToDo: we may generate silly RdrNames, by passing a name space
799 -- that doesn't match the string, like VarName ":+",
800 -- which will give confusing error messages later
802 -- The strict applications ensure that any buried exceptions get forced
803 thRdrName _ occ (TH.NameG th_ns pkg mod) = thOrigRdrName occ th_ns pkg mod
804 thRdrName ctxt_ns occ (TH.NameL uniq) = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcSpan)
805 thRdrName ctxt_ns occ (TH.NameQ mod) = (mkRdrQual $! (mk_mod mod)) $! (mk_occ ctxt_ns occ)
806 thRdrName ctxt_ns occ (TH.NameU uniq) = mkRdrUnqual $! (mk_uniq_occ ctxt_ns occ uniq)
807 thRdrName ctxt_ns occ TH.NameS
808 | Just name <- isBuiltInOcc ctxt_ns occ = nameRdrName $! name
809 | otherwise = mkRdrUnqual $! (mk_occ ctxt_ns occ)
811 thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
812 thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)
814 thRdrNameGuesses :: TH.Name -> [RdrName]
815 thRdrNameGuesses (TH.Name occ flavour)
816 -- This special case for NameG ensures that we don't generate duplicates in the output list
817 | TH.NameG th_ns pkg mod <- flavour = [thOrigRdrName occ_str th_ns pkg mod]
818 | otherwise = [ thRdrName gns occ_str flavour
819 | gns <- guessed_nss]
821 -- guessed_ns are the name spaces guessed from looking at the TH name
822 guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName, OccName.dataName]
823 | otherwise = [OccName.varName, OccName.tvName]
824 occ_str = TH.occString occ
826 isBuiltInOcc :: OccName.NameSpace -> String -> Maybe Name.Name
827 -- Built in syntax isn't "in scope" so an Unqual RdrName won't do
828 -- We must generate an Exact name, just as the parser does
829 isBuiltInOcc ctxt_ns occ
831 ":" -> Just (Name.getName consDataCon)
832 "[]" -> Just (Name.getName nilDataCon)
833 "()" -> Just (tup_name 0)
834 '(' : ',' : rest -> go_tuple 2 rest
837 go_tuple n ")" = Just (tup_name n)
838 go_tuple n (',' : rest) = go_tuple (n+1) rest
839 go_tuple _ _ = Nothing
842 | OccName.isTcClsNameSpace ctxt_ns = Name.getName (tupleTyCon Boxed n)
843 | otherwise = Name.getName (tupleCon Boxed n)
845 mk_uniq_occ :: OccName.NameSpace -> String -> Int# -> OccName.OccName
846 mk_uniq_occ ns occ uniq
847 = OccName.mkOccName ns (occ ++ '[' : shows (mk_uniq uniq) "]")
848 -- See Note [Unique OccNames from Template Haskell]
850 -- The packing and unpacking is rather turgid :-(
851 mk_occ :: OccName.NameSpace -> String -> OccName.OccName
852 mk_occ ns occ = OccName.mkOccNameFS ns (mkFastString occ)
854 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
855 mk_ghc_ns TH.DataName = OccName.dataName
856 mk_ghc_ns TH.TcClsName = OccName.tcClsName
857 mk_ghc_ns TH.VarName = OccName.varName
859 mk_mod :: TH.ModName -> ModuleName
860 mk_mod mod = mkModuleName (TH.modString mod)
862 mk_pkg :: TH.PkgName -> PackageId
863 mk_pkg pkg = stringToPackageId (TH.pkgString pkg)
865 mk_uniq :: Int# -> Unique
866 mk_uniq u = mkUniqueGrimily (I# u)
869 Note [Unique OccNames from Template Haskell]
870 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
871 The idea here is to make a name that
872 a) the user could not possibly write (it has a "["
873 and letters or digits from the unique)
874 b) cannot clash with another NameU
875 Previously I generated an Exact RdrName with mkInternalName. This
876 works fine for local binders, but does not work at all for top-level
877 binders, which must have External Names, since they are rapidly baked
878 into data constructors and the like. Baling out and generating an
879 unqualified RdrName here is the simple solution
881 See also Note [Suppressing uniques in OccNames] in OccName, which
882 suppresses the unique when opt_SuppressUniques is on.