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 = inl_spec, inl_sat = Nothing }
405 matchinfo = cvtRuleMatchInfo conlike
406 opt_activation' = cvtActivation opt_activation
408 cvtRuleMatchInfo False = FunLike
409 cvtRuleMatchInfo True = ConLike
411 inl_spec | inline = Inline
412 | otherwise = NoInline
413 -- Currently we have no way to say Inlinable
415 cvtActivation Nothing | inline = AlwaysActive
416 | otherwise = NeverActive
417 cvtActivation (Just (False, phase)) = ActiveBefore phase
418 cvtActivation (Just (True , phase)) = ActiveAfter phase
420 ---------------------------------------------------
422 ---------------------------------------------------
424 cvtLocalDecs :: Message -> [TH.Dec] -> CvtM (HsLocalBinds RdrName)
427 = return EmptyLocalBinds
429 = do { ds' <- mapM cvtDec ds
430 ; let (binds, prob_sigs) = partitionWith is_bind ds'
431 ; let (sigs, bads) = partitionWith is_sig prob_sigs
432 ; unless (null bads) (failWith (mkBadDecMsg doc bads))
433 ; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) }
435 cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName)
436 cvtClause (Clause ps body wheres)
437 = do { ps' <- cvtPats ps
438 ; g' <- cvtGuard body
439 ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) wheres
440 ; returnL $ Hs.Match ps' Nothing (GRHSs g' ds') }
443 -------------------------------------------------------------------
445 -------------------------------------------------------------------
447 cvtl :: TH.Exp -> CvtM (LHsExpr RdrName)
448 cvtl e = wrapL (cvt e)
450 cvt (VarE s) = do { s' <- vName s; return $ HsVar s' }
451 cvt (ConE s) = do { s' <- cName s; return $ HsVar s' }
453 | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }
454 | otherwise = do { l' <- cvtLit l; return $ HsLit l' }
456 cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' }
457 cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e
458 ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) }
459 cvt (TupE [e]) = cvt e -- Singleton tuples treated like nothing (just parens)
460 cvt (TupE es) = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Boxed }
461 cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z
462 ; return $ HsIf x' y' z' }
463 cvt (LetE ds e) = do { ds' <- cvtLocalDecs (ptext (sLit "a let expression")) ds
464 ; e' <- cvtl e; return $ HsLet ds' e' }
466 | null ms = failWith (ptext (sLit "Case expression with no alternatives"))
467 | otherwise = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
468 ; return $ HsCase e' (mkMatchGroup ms') }
469 cvt (DoE ss) = cvtHsDo DoExpr ss
470 cvt (CompE ss) = cvtHsDo ListComp ss
471 cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr dd' }
473 | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s); return (HsLit l') }
474 -- Note [Converting strings]
475 | otherwise = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' }
476 cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
477 ; e' <- returnL $ OpApp x' s' undefined y'
478 ; return $ HsPar e' }
479 cvt (InfixE Nothing s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
480 ; sec <- returnL $ SectionR s' y'
481 ; return $ HsPar sec }
482 cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
483 ; sec <- returnL $ SectionL x' s'
484 ; return $ HsPar sec }
485 cvt (InfixE Nothing s Nothing ) = cvt s -- Can I indicate this is an infix thing?
487 cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t
488 ; return $ ExprWithTySig e' t' }
489 cvt (RecConE c flds) = do { c' <- cNameL c
490 ; flds' <- mapM cvtFld flds
491 ; return $ RecordCon c' noPostTcExpr (HsRecFields flds' Nothing)}
492 cvt (RecUpdE e flds) = do { e' <- cvtl e
493 ; flds' <- mapM cvtFld flds
494 ; return $ RecordUpd e' (HsRecFields flds' Nothing) [] [] [] }
496 cvtFld :: (TH.Name, TH.Exp) -> CvtM (HsRecField RdrName (LHsExpr RdrName))
498 = do { v' <- vNameL v; e' <- cvtl e
499 ; return (HsRecField { hsRecFieldId = v', hsRecFieldArg = e', hsRecPun = False}) }
501 cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)
502 cvtDD (FromR x) = do { x' <- cvtl x; return $ From x' }
503 cvtDD (FromThenR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }
504 cvtDD (FromToR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
505 cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }
507 -------------------------------------
508 -- Do notation and statements
509 -------------------------------------
511 cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr RdrName)
512 cvtHsDo do_or_lc stmts
513 | null stmts = failWith (ptext (sLit "Empty stmt list in do-block"))
515 = do { stmts' <- cvtStmts stmts
516 ; body <- case last stmts' of
517 L _ (ExprStmt body _ _) -> return body
518 stmt' -> failWith (bad_last stmt')
519 ; return $ HsDo do_or_lc (init stmts') body void }
521 bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprStmtContext do_or_lc <> colon
522 , nest 2 $ Outputable.ppr stmt
523 , ptext (sLit "(It should be an expression.)") ]
525 cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName]
526 cvtStmts = mapM cvtStmt
528 cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName)
529 cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkExprStmt e' }
530 cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
531 cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (ptext (sLit "a let binding")) ds
532 ; returnL $ LetStmt ds' }
533 cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' }
535 cvt_one ds = do { ds' <- cvtStmts ds; return (ds', undefined) }
537 cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName)
538 cvtMatch (TH.Match p body decs)
539 = do { p' <- cvtPat p
540 ; g' <- cvtGuard body
541 ; decs' <- cvtLocalDecs (ptext (sLit "a where clause")) decs
542 ; returnL $ Hs.Match [p'] Nothing (GRHSs g' decs') }
544 cvtGuard :: TH.Body -> CvtM [LGRHS RdrName]
545 cvtGuard (GuardedB pairs) = mapM cvtpair pairs
546 cvtGuard (NormalB e) = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] }
548 cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName)
549 cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
550 ; g' <- returnL $ mkExprStmt ge'
551 ; returnL $ GRHS [g'] rhs' }
552 cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
553 ; returnL $ GRHS gs' rhs' }
555 cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
556 cvtOverLit (IntegerL i)
557 = do { force i; return $ mkHsIntegral i placeHolderType}
558 cvtOverLit (RationalL r)
559 = do { force r; return $ mkHsFractional r placeHolderType}
560 cvtOverLit (StringL s)
561 = do { let { s' = mkFastString s }
563 ; return $ mkHsIsString s' placeHolderType
565 cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
566 -- An Integer is like an (overloaded) '3' in a Haskell source program
567 -- Similarly 3.5 for fractionals
569 {- Note [Converting strings]
570 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
571 If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to
572 a string literal for "xy". Of course, we might hope to get
573 (LitE (StringL "xy")), but not always, and allCharLs fails quickly
574 if it isn't a literal string
577 allCharLs :: [TH.Exp] -> Maybe String
578 -- Note [Converting strings]
579 -- NB: only fire up this setup for a non-empty list, else
580 -- there's a danger of returning "" for [] :: [Int]!
583 LitE (CharL c) : ys -> go [c] ys
586 go cs [] = Just (reverse cs)
587 go cs (LitE (CharL c) : ys) = go (c:cs) ys
590 cvtLit :: Lit -> CvtM HsLit
591 cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim i }
592 cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim w }
593 cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim f }
594 cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim f }
595 cvtLit (CharL c) = do { force c; return $ HsChar c }
596 cvtLit (StringL s) = do { let { s' = mkFastString s }
598 ; return $ HsString s' }
599 cvtLit (StringPrimL s) = do { let { s' = mkFastString s }
601 ; return $ HsStringPrim s' }
602 cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
603 -- cvtLit should not be called on IntegerL, RationalL
604 -- That precondition is established right here in
605 -- Convert.lhs, hence panic
607 cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName]
608 cvtPats pats = mapM cvtPat pats
610 cvtPat :: TH.Pat -> CvtM (Hs.LPat RdrName)
611 cvtPat pat = wrapL (cvtp pat)
613 cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName)
615 | overloadedLit l = do { l' <- cvtOverLit l
616 ; return (mkNPat l' Nothing) }
617 -- Not right for negative patterns;
618 -- need to think about that!
619 | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat l' }
620 cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat s' }
621 cvtp (TupP [p]) = cvtp p
622 cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void }
623 cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps; return $ ConPatIn s' (PrefixCon ps') }
624 cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
625 ; return $ ConPatIn s' (InfixCon p1' p2') }
626 cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat p' }
627 cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat p' }
628 cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
629 cvtp TH.WildP = return $ WildPat void
630 cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
631 ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
632 cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void }
633 cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' }
635 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
637 = do { s' <- vNameL s; p' <- cvtPat p
638 ; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) }
640 -----------------------------------------------------------
641 -- Types and type variables
643 cvtTvs :: [TH.TyVarBndr] -> CvtM [LHsTyVarBndr RdrName]
644 cvtTvs tvs = mapM cvt_tv tvs
646 cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
647 cvt_tv (TH.PlainTV nm)
648 = do { nm' <- tName nm
649 ; returnL $ UserTyVar nm' placeHolderKind
651 cvt_tv (TH.KindedTV nm ki)
652 = do { nm' <- tName nm
653 ; returnL $ KindedTyVar nm' (cvtKind ki)
656 cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
657 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
659 cvtPred :: TH.Pred -> CvtM (LHsPred RdrName)
660 cvtPred (TH.ClassP cla tys)
661 = do { cla' <- if isVarName cla then tName cla else tconName cla
662 ; tys' <- mapM cvtType tys
663 ; returnL $ HsClassP cla' tys'
665 cvtPred (TH.EqualP ty1 ty2)
666 = do { ty1' <- cvtType ty1
667 ; ty2' <- cvtType ty2
668 ; returnL $ HsEqualP ty1' ty2'
671 cvtPredTy :: TH.Type -> CvtM (LHsPred RdrName)
673 = do { (head, tys') <- split_ty_app ty
675 ConT tc -> do { tc' <- tconName tc; returnL $ HsClassP tc' tys' }
676 VarT tv -> do { tv' <- tName tv; returnL $ HsClassP tv' tys' }
677 _ -> failWith (ptext (sLit "Malformed predicate") <+>
678 text (TH.pprint ty)) }
680 cvtType :: TH.Type -> CvtM (LHsType RdrName)
682 = do { (head_ty, tys') <- split_ty_app ty
685 | length tys' == n -- Saturated
686 -> if n==1 then return (head tys') -- Singleton tuples treated
687 -- like nothing (ie just parens)
688 else returnL (HsTupleTy Boxed tys')
690 -> failWith (ptext (sLit "Illegal 1-tuple type constructor"))
692 -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys'
694 | [x',y'] <- tys' -> returnL (HsFunTy x' y')
695 | otherwise -> mk_apps (HsTyVar (getRdrName funTyCon)) tys'
697 | [x'] <- tys' -> returnL (HsListTy x')
698 | otherwise -> mk_apps (HsTyVar (getRdrName listTyCon)) tys'
699 VarT nm -> do { nm' <- tName nm; mk_apps (HsTyVar nm') tys' }
700 ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' }
704 -> do { tvs' <- cvtTvs tvs
705 ; cxt' <- cvtContext cxt
707 ; returnL $ mkExplicitHsForAllTy tvs' cxt' ty'
711 -> do { ty' <- cvtType ty
712 ; mk_apps (HsKindSig ty' (cvtKind ki)) tys'
715 _ -> failWith (ptext (sLit "Malformed type") <+> text (show ty))
718 mk_apps head_ty [] = returnL head_ty
719 mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
720 ; mk_apps (HsAppTy head_ty' ty) tys }
722 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
723 split_ty_app ty = go ty []
725 go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
726 go f as = return (f,as)
728 cvtKind :: TH.Kind -> Type.Kind
729 cvtKind StarK = liftedTypeKind
730 cvtKind (ArrowK k1 k2) = mkArrowKind (cvtKind k1) (cvtKind k2)
732 -----------------------------------------------------------
735 -----------------------------------------------------------
736 -- some useful things
738 overloadedLit :: Lit -> Bool
739 -- True for literals that Haskell treats as overloaded
740 overloadedLit (IntegerL _) = True
741 overloadedLit (RationalL _) = True
742 overloadedLit _ = False
745 void = placeHolderType
747 --------------------------------------------------------------------
748 -- Turning Name back into RdrName
749 --------------------------------------------------------------------
752 vNameL, cNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
753 vName, cName, tName, tconName :: TH.Name -> CvtM RdrName
755 vNameL n = wrapL (vName n)
756 vName n = cvtName OccName.varName n
758 -- Constructor function names; this is Haskell source, hence srcDataName
759 cNameL n = wrapL (cName n)
760 cName n = cvtName OccName.dataName n
762 -- Type variable names
763 tName n = cvtName OccName.tvName n
765 -- Type Constructor names
766 tconNameL n = wrapL (tconName n)
767 tconName n = cvtName OccName.tcClsName n
769 cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
770 cvtName ctxt_ns (TH.Name occ flavour)
771 | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
772 | otherwise = force rdr_name >> return rdr_name
774 occ_str = TH.occString occ
775 rdr_name = thRdrName ctxt_ns occ_str flavour
777 okOcc :: OccName.NameSpace -> String -> Bool
780 | OccName.isVarNameSpace ns = startsVarId c || startsVarSym c
781 | otherwise = startsConId c || startsConSym c || str == "[]"
783 -- Determine the name space of a name in a type
785 isVarName :: TH.Name -> Bool
786 isVarName (TH.Name occ _)
787 = case TH.occString occ of
789 (c:_) -> startsVarId c || startsVarSym c
791 badOcc :: OccName.NameSpace -> String -> SDoc
793 = ptext (sLit "Illegal") <+> pprNameSpace ctxt_ns
794 <+> ptext (sLit "name:") <+> quotes (text occ)
796 thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
797 -- This turns a Name into a RdrName
798 -- The passed-in name space tells what the context is expecting;
799 -- use it unless the TH name knows what name-space it comes
800 -- from, in which case use the latter
802 -- ToDo: we may generate silly RdrNames, by passing a name space
803 -- that doesn't match the string, like VarName ":+",
804 -- which will give confusing error messages later
806 -- The strict applications ensure that any buried exceptions get forced
807 thRdrName _ occ (TH.NameG th_ns pkg mod) = thOrigRdrName occ th_ns pkg mod
808 thRdrName ctxt_ns occ (TH.NameL uniq) = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcSpan)
809 thRdrName ctxt_ns occ (TH.NameQ mod) = (mkRdrQual $! (mk_mod mod)) $! (mk_occ ctxt_ns occ)
810 thRdrName ctxt_ns occ (TH.NameU uniq) = mkRdrUnqual $! (mk_uniq_occ ctxt_ns occ uniq)
811 thRdrName ctxt_ns occ TH.NameS
812 | Just name <- isBuiltInOcc ctxt_ns occ = nameRdrName $! name
813 | otherwise = mkRdrUnqual $! (mk_occ ctxt_ns occ)
815 thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
816 thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)
818 thRdrNameGuesses :: TH.Name -> [RdrName]
819 thRdrNameGuesses (TH.Name occ flavour)
820 -- This special case for NameG ensures that we don't generate duplicates in the output list
821 | TH.NameG th_ns pkg mod <- flavour = [thOrigRdrName occ_str th_ns pkg mod]
822 | otherwise = [ thRdrName gns occ_str flavour
823 | gns <- guessed_nss]
825 -- guessed_ns are the name spaces guessed from looking at the TH name
826 guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName, OccName.dataName]
827 | otherwise = [OccName.varName, OccName.tvName]
828 occ_str = TH.occString occ
830 isBuiltInOcc :: OccName.NameSpace -> String -> Maybe Name.Name
831 -- Built in syntax isn't "in scope" so an Unqual RdrName won't do
832 -- We must generate an Exact name, just as the parser does
833 isBuiltInOcc ctxt_ns occ
835 ":" -> Just (Name.getName consDataCon)
836 "[]" -> Just (Name.getName nilDataCon)
837 "()" -> Just (tup_name 0)
838 '(' : ',' : rest -> go_tuple 2 rest
841 go_tuple n ")" = Just (tup_name n)
842 go_tuple n (',' : rest) = go_tuple (n+1) rest
843 go_tuple _ _ = Nothing
846 | OccName.isTcClsNameSpace ctxt_ns = Name.getName (tupleTyCon Boxed n)
847 | otherwise = Name.getName (tupleCon Boxed n)
849 mk_uniq_occ :: OccName.NameSpace -> String -> Int# -> OccName.OccName
850 mk_uniq_occ ns occ uniq
851 = OccName.mkOccName ns (occ ++ '[' : shows (mk_uniq uniq) "]")
852 -- See Note [Unique OccNames from Template Haskell]
854 -- The packing and unpacking is rather turgid :-(
855 mk_occ :: OccName.NameSpace -> String -> OccName.OccName
856 mk_occ ns occ = OccName.mkOccNameFS ns (mkFastString occ)
858 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
859 mk_ghc_ns TH.DataName = OccName.dataName
860 mk_ghc_ns TH.TcClsName = OccName.tcClsName
861 mk_ghc_ns TH.VarName = OccName.varName
863 mk_mod :: TH.ModName -> ModuleName
864 mk_mod mod = mkModuleName (TH.modString mod)
866 mk_pkg :: TH.PkgName -> PackageId
867 mk_pkg pkg = stringToPackageId (TH.pkgString pkg)
869 mk_uniq :: Int# -> Unique
870 mk_uniq u = mkUniqueGrimily (I# u)
873 Note [Unique OccNames from Template Haskell]
874 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
875 The idea here is to make a name that
876 a) the user could not possibly write (it has a "["
877 and letters or digits from the unique)
878 b) cannot clash with another NameU
879 Previously I generated an Exact RdrName with mkInternalName. This
880 works fine for local binders, but does not work at all for top-level
881 binders, which must have External Names, since they are rapidly baked
882 into data constructors and the like. Baling out and generating an
883 unqualified RdrName here is the simple solution
885 See also Note [Suppressing uniques in OccNames] in OccName, which
886 suppresses the unique when opt_SuppressUniques is on.