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, convertToHsPred,
11 thRdrNameGuesses ) where
14 import qualified Class
19 import qualified OccName
25 import BasicTypes as Hs
35 import Control.Monad( unless )
37 import Language.Haskell.TH as TH hiding (sigP)
38 import Language.Haskell.TH.Syntax as TH
42 -------------------------------------------------------------------
43 -- The external interface
45 convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName]
46 convertToHsDecls loc ds = initCvt loc (mapM cvt_dec ds)
48 cvt_dec d = wrapMsg "declaration" d (cvtDec d)
50 convertToHsExpr :: SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName)
52 = initCvt loc $ wrapMsg "expression" e $ cvtl e
54 convertToPat :: SrcSpan -> TH.Pat -> Either Message (LPat RdrName)
56 = initCvt loc $ wrapMsg "pattern" p $ cvtPat p
58 convertToHsType :: SrcSpan -> TH.Type -> Either Message (LHsType RdrName)
60 = initCvt loc $ wrapMsg "type" t $ cvtType t
62 convertToHsPred :: SrcSpan -> TH.Pred -> Either Message (LHsPred RdrName)
64 = initCvt loc $ wrapMsg "type" t $ cvtPred t
66 -------------------------------------------------------------------
67 newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either Message a }
68 -- Push down the source location;
69 -- Can fail, with a single error message
71 -- NB: If the conversion succeeds with (Right x), there should
72 -- be no exception values hiding in x
73 -- Reason: so a (head []) in TH code doesn't subsequently
74 -- make GHC crash when it tries to walk the generated tree
76 -- Use the loc everywhere, for lack of anything better
77 -- In particular, we want it on binding locations, so that variables bound in
78 -- the spliced-in declarations get a location that at least relates to the splice point
80 instance Monad CvtM where
81 return x = CvtM $ \_ -> Right x
82 (CvtM m) >>= k = CvtM $ \loc -> case m loc of
84 Right v -> unCvtM (k v) loc
86 initCvt :: SrcSpan -> CvtM a -> Either Message a
87 initCvt loc (CvtM m) = m loc
90 force a = a `seq` return ()
92 failWith :: Message -> CvtM a
93 failWith m = CvtM (\_ -> Left m)
95 returnL :: a -> CvtM (Located a)
96 returnL x = CvtM (\loc -> Right (L loc x))
98 wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b
99 -- E.g wrapMsg "declaration" dec thing
100 wrapMsg what item (CvtM m)
101 = CvtM (\loc -> case m loc of
102 Left err -> Left (err $$ getPprStyle msg)
105 -- Show the item in pretty syntax normally,
106 -- but with all its constructors if you say -dppr-debug
107 msg sty = hang (ptext (sLit "When splicing a TH") <+> text what <> colon)
109 then text (show item)
110 else text (pprint item))
112 wrapL :: CvtM a -> CvtM (Located a)
113 wrapL (CvtM m) = CvtM (\loc -> case m loc of
115 Right v -> Right (L loc v))
117 -------------------------------------------------------------------
118 cvtDec :: TH.Dec -> CvtM (LHsDecl RdrName)
119 cvtDec (TH.ValD pat body ds)
121 = do { s' <- vNameL s
122 ; cl' <- cvtClause (Clause [] body ds)
123 ; returnL $ Hs.ValD $ mkFunBind s' [cl'] }
126 = do { pat' <- cvtPat pat
127 ; body' <- cvtGuard body
128 ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) ds
129 ; returnL $ Hs.ValD $
130 PatBind { pat_lhs = pat', pat_rhs = GRHSs body' ds'
131 , pat_rhs_ty = void, bind_fvs = placeHolderNames } }
133 cvtDec (TH.FunD nm cls)
135 = failWith (ptext (sLit "Function binding for")
136 <+> quotes (text (TH.pprint nm))
137 <+> ptext (sLit "has no equations"))
139 = do { nm' <- vNameL nm
140 ; cls' <- mapM cvtClause cls
141 ; returnL $ Hs.ValD $ mkFunBind nm' cls' }
143 cvtDec (TH.SigD nm typ)
144 = do { nm' <- vNameL nm
146 ; returnL $ Hs.SigD (TypeSig nm' ty') }
148 cvtDec (PragmaD prag)
149 = do { prag' <- cvtPragmaD prag
150 ; returnL $ Hs.SigD prag' }
152 cvtDec (TySynD tc tvs rhs)
153 = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
154 ; rhs' <- cvtType rhs
155 ; returnL $ TyClD (TySynonym tc' tvs' Nothing rhs') }
157 cvtDec (DataD ctxt tc tvs constrs derivs)
158 = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
159 ; cons' <- mapM cvtConstr constrs
160 ; derivs' <- cvtDerivs derivs
161 ; returnL $ TyClD (TyData { tcdND = DataType, tcdLName = tc', tcdCtxt = ctxt'
162 , tcdTyVars = tvs', tcdTyPats = Nothing, tcdKindSig = Nothing
163 , tcdCons = cons', tcdDerivs = derivs' }) }
165 cvtDec (NewtypeD ctxt tc tvs constr derivs)
166 = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
167 ; con' <- cvtConstr constr
168 ; derivs' <- cvtDerivs derivs
169 ; returnL $ TyClD (TyData { tcdND = NewType, tcdLName = tc', tcdCtxt = ctxt'
170 , tcdTyVars = tvs', tcdTyPats = Nothing, tcdKindSig = Nothing
171 , tcdCons = [con'], tcdDerivs = derivs'}) }
173 cvtDec (ClassD ctxt cl tvs fds decs)
174 = do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
175 ; fds' <- mapM cvt_fundep fds
176 ; (binds', sigs', ats') <- cvt_ci_decs (ptext (sLit "a class declaration")) decs
178 TyClD $ ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
179 , tcdFDs = fds', tcdSigs = sigs', tcdMeths = binds'
180 , tcdATs = ats', tcdDocs = [] }
184 cvtDec (InstanceD ctxt ty decs)
185 = do { (binds', sigs', ats') <- cvt_ci_decs (ptext (sLit "an instance declaration")) decs
186 ; ctxt' <- cvtContext ctxt
187 ; L loc pred' <- cvtPredTy ty
188 ; let inst_ty' = L loc $ mkImplicitHsForAllTy ctxt' $ L loc $ HsPredTy pred'
189 ; returnL $ InstD (InstDecl inst_ty' binds' sigs' ats') }
191 cvtDec (ForeignD ford)
192 = do { ford' <- cvtForD ford
193 ; returnL $ ForD ford' }
195 cvtDec (FamilyD flav tc tvs kind)
196 = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
197 ; let kind' = fmap cvtKind kind
198 ; returnL $ TyClD (TyFamily (cvtFamFlavour flav) tc' tvs' kind') }
200 cvtFamFlavour TypeFam = TypeFamily
201 cvtFamFlavour DataFam = DataFamily
203 cvtDec (DataInstD ctxt tc tys constrs derivs)
204 = do { (ctxt', tc', tvs', typats') <- cvt_tyinst_hdr ctxt tc tys
205 ; cons' <- mapM cvtConstr constrs
206 ; derivs' <- cvtDerivs derivs
207 ; returnL $ TyClD (TyData { tcdND = DataType, tcdLName = tc', tcdCtxt = ctxt'
208 , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing
209 , tcdCons = cons', tcdDerivs = derivs' }) }
211 cvtDec (NewtypeInstD ctxt tc tys constr derivs)
212 = do { (ctxt', tc', tvs', typats') <- cvt_tyinst_hdr ctxt tc tys
213 ; con' <- cvtConstr constr
214 ; derivs' <- cvtDerivs derivs
215 ; returnL $ TyClD (TyData { tcdND = NewType, tcdLName = tc', tcdCtxt = ctxt'
216 , tcdTyVars = tvs', tcdTyPats = typats', tcdKindSig = Nothing
217 , tcdCons = [con'], tcdDerivs = derivs' })
220 cvtDec (TySynInstD tc tys rhs)
221 = do { (_, tc', tvs', tys') <- cvt_tyinst_hdr [] tc tys
222 ; rhs' <- cvtType rhs
223 ; returnL $ TyClD (TySynonym tc' tvs' tys' rhs') }
226 cvt_ci_decs :: Message -> [TH.Dec]
227 -> CvtM (LHsBinds RdrName,
230 -- Convert the declarations inside a class or instance decl
231 -- ie signatures, bindings, and associated types
233 = do { decs' <- mapM cvtDec decs
234 ; let (ats', bind_sig_decs') = partitionWith is_tycl decs'
235 ; let (sigs', prob_binds') = partitionWith is_sig bind_sig_decs'
236 ; let (binds', bads) = partitionWith is_bind prob_binds'
237 ; unless (null bads) (failWith (mkBadDecMsg doc bads))
238 ; return (listToBag binds', sigs', ats') }
241 cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
242 -> CvtM ( LHsContext RdrName
244 , [LHsTyVarBndr RdrName])
245 cvt_tycl_hdr cxt tc tvs
246 = do { cxt' <- cvtContext cxt
247 ; tc' <- tconNameL tc
249 ; return (cxt', tc', tvs')
252 cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
253 -> CvtM ( LHsContext RdrName
255 , [LHsTyVarBndr RdrName]
256 , Maybe [LHsType RdrName])
257 cvt_tyinst_hdr cxt tc tys
258 = do { cxt' <- cvtContext cxt
259 ; tc' <- tconNameL tc
260 ; tvs <- concatMapM collect tys
262 ; tys' <- mapM cvtType tys
263 ; return (cxt', tc', tvs', Just tys')
266 collect (ForallT _ _ _)
267 = failWith $ text "Forall type not allowed as type parameter"
268 collect (VarT tv) = return [PlainTV tv]
269 collect (ConT _) = return []
270 collect (TupleT _) = return []
271 collect ArrowT = return []
272 collect ListT = return []
274 = do { tvs1 <- collect t1
276 ; return $ tvs1 ++ tvs2
278 collect (SigT (VarT tv) ki) = return [KindedTV tv ki]
279 collect (SigT ty _) = collect ty
281 -------------------------------------------------------------------
282 -- Partitioning declarations
283 -------------------------------------------------------------------
285 is_tycl :: LHsDecl RdrName -> Either (LTyClDecl RdrName) (LHsDecl RdrName)
286 is_tycl (L loc (Hs.TyClD tcd)) = Left (L loc tcd)
287 is_tycl decl = Right decl
289 is_sig :: LHsDecl RdrName -> Either (LSig RdrName) (LHsDecl RdrName)
290 is_sig (L loc (Hs.SigD sig)) = Left (L loc sig)
291 is_sig decl = Right decl
293 is_bind :: LHsDecl RdrName -> Either (LHsBind RdrName) (LHsDecl RdrName)
294 is_bind (L loc (Hs.ValD bind)) = Left (L loc bind)
295 is_bind decl = Right decl
297 mkBadDecMsg :: Message -> [LHsDecl RdrName] -> Message
299 = sep [ ptext (sLit "Illegal declaration(s) in") <+> doc <> colon
300 , nest 2 (vcat (map Outputable.ppr bads)) ]
302 ---------------------------------------------------
304 -- Can't handle GADTs yet
305 ---------------------------------------------------
307 cvtConstr :: TH.Con -> CvtM (LConDecl RdrName)
309 cvtConstr (NormalC c strtys)
310 = do { c' <- cNameL c
312 ; tys' <- mapM cvt_arg strtys
313 ; returnL $ mkSimpleConDecl c' noExistentials cxt' (PrefixCon tys') }
315 cvtConstr (RecC c varstrtys)
316 = do { c' <- cNameL c
318 ; args' <- mapM cvt_id_arg varstrtys
319 ; returnL $ mkSimpleConDecl c' noExistentials cxt' (RecCon args') }
321 cvtConstr (InfixC st1 c st2)
322 = do { c' <- cNameL c
324 ; st1' <- cvt_arg st1
325 ; st2' <- cvt_arg st2
326 ; returnL $ mkSimpleConDecl c' noExistentials cxt' (InfixCon st1' st2') }
328 cvtConstr (ForallC tvs ctxt con)
329 = do { tvs' <- cvtTvs tvs
330 ; L loc ctxt' <- cvtContext ctxt
331 ; L _ con' <- cvtConstr con
332 ; returnL $ con' { con_qvars = tvs' ++ con_qvars con'
333 , con_cxt = L loc (ctxt' ++ (unLoc $ con_cxt con')) } }
335 cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
336 cvt_arg (IsStrict, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy HsStrict ty' }
337 cvt_arg (NotStrict, ty) = cvtType ty
339 cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (ConDeclField RdrName)
340 cvt_id_arg (i, str, ty)
341 = do { i' <- vNameL i
342 ; ty' <- cvt_arg (str,ty)
343 ; return (ConDeclField { cd_fld_name = i', cd_fld_type = ty', cd_fld_doc = Nothing}) }
345 cvtDerivs :: [TH.Name] -> CvtM (Maybe [LHsType RdrName])
346 cvtDerivs [] = return Nothing
347 cvtDerivs cs = do { cs' <- mapM cvt_one cs
348 ; return (Just cs') }
350 cvt_one c = do { c' <- tconName c
351 ; returnL $ HsPredTy $ HsClassP c' [] }
353 cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep RdrName))
354 cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs; ys' <- mapM tName ys; returnL (xs', ys') }
356 noExistentials :: [LHsTyVarBndr RdrName]
359 ------------------------------------------
360 -- Foreign declarations
361 ------------------------------------------
363 cvtForD :: Foreign -> CvtM (ForeignDecl RdrName)
364 cvtForD (ImportF callconv safety from nm ty)
365 | Just impspec <- parseCImport (cvt_conv callconv) safety'
366 (mkFastString (TH.nameBase nm)) from
367 = do { nm' <- vNameL nm
369 ; return (ForeignImport nm' ty' impspec)
372 = failWith $ text (show from) <+> ptext (sLit "is not a valid ccall impent")
374 safety' = case safety of
376 Safe -> PlaySafe False
377 Threadsafe -> PlaySafe True
379 cvtForD (ExportF callconv as nm ty)
380 = do { nm' <- vNameL nm
382 ; let e = CExport (CExportStatic (mkFastString as) (cvt_conv callconv))
383 ; return $ ForeignExport nm' ty' e }
385 cvt_conv :: TH.Callconv -> CCallConv
386 cvt_conv TH.CCall = CCallConv
387 cvt_conv TH.StdCall = StdCallConv
389 ------------------------------------------
391 ------------------------------------------
393 cvtPragmaD :: Pragma -> CvtM (Sig RdrName)
394 cvtPragmaD (InlineP nm ispec)
395 = do { nm' <- vNameL nm
396 ; return $ InlineSig nm' (cvtInlineSpec (Just ispec)) }
398 cvtPragmaD (SpecialiseP nm ty opt_ispec)
399 = do { nm' <- vNameL nm
401 ; return $ SpecSig nm' ty' (cvtInlineSpec opt_ispec) }
403 cvtInlineSpec :: Maybe TH.InlineSpec -> Hs.InlinePragma
404 cvtInlineSpec Nothing
405 = defaultInlinePragma
406 cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation))
407 = InlinePragma { inl_act = opt_activation', inl_rule = matchinfo
408 , inl_inline = inl_spec, inl_sat = Nothing }
410 matchinfo = cvtRuleMatchInfo conlike
411 opt_activation' = cvtActivation opt_activation
413 cvtRuleMatchInfo False = FunLike
414 cvtRuleMatchInfo True = ConLike
416 inl_spec | inline = Inline
417 | otherwise = NoInline
418 -- Currently we have no way to say Inlinable
420 cvtActivation Nothing | inline = AlwaysActive
421 | otherwise = NeverActive
422 cvtActivation (Just (False, phase)) = ActiveBefore phase
423 cvtActivation (Just (True , phase)) = ActiveAfter phase
425 ---------------------------------------------------
427 ---------------------------------------------------
429 cvtLocalDecs :: Message -> [TH.Dec] -> CvtM (HsLocalBinds RdrName)
432 = return EmptyLocalBinds
434 = do { ds' <- mapM cvtDec ds
435 ; let (binds, prob_sigs) = partitionWith is_bind ds'
436 ; let (sigs, bads) = partitionWith is_sig prob_sigs
437 ; unless (null bads) (failWith (mkBadDecMsg doc bads))
438 ; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) }
440 cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName)
441 cvtClause (Clause ps body wheres)
442 = do { ps' <- cvtPats ps
443 ; g' <- cvtGuard body
444 ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) wheres
445 ; returnL $ Hs.Match ps' Nothing (GRHSs g' ds') }
448 -------------------------------------------------------------------
450 -------------------------------------------------------------------
452 cvtl :: TH.Exp -> CvtM (LHsExpr RdrName)
453 cvtl e = wrapL (cvt e)
455 cvt (VarE s) = do { s' <- vName s; return $ HsVar s' }
456 cvt (ConE s) = do { s' <- cName s; return $ HsVar s' }
458 | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }
459 | otherwise = do { l' <- cvtLit l; return $ HsLit l' }
461 cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' }
462 cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e
463 ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) }
464 cvt (TupE [e]) = cvt e -- Singleton tuples treated like nothing (just parens)
465 cvt (TupE es) = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Boxed }
466 cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z
467 ; return $ HsIf x' y' z' }
468 cvt (LetE ds e) = do { ds' <- cvtLocalDecs (ptext (sLit "a let expression")) ds
469 ; e' <- cvtl e; return $ HsLet ds' e' }
471 | null ms = failWith (ptext (sLit "Case expression with no alternatives"))
472 | otherwise = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
473 ; return $ HsCase e' (mkMatchGroup ms') }
474 cvt (DoE ss) = cvtHsDo DoExpr ss
475 cvt (CompE ss) = cvtHsDo ListComp ss
476 cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr dd' }
478 | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s); return (HsLit l') }
479 -- Note [Converting strings]
480 | otherwise = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' }
481 cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
482 ; e' <- returnL $ OpApp x' s' undefined y'
483 ; return $ HsPar e' }
484 cvt (InfixE Nothing s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
485 ; sec <- returnL $ SectionR s' y'
486 ; return $ HsPar sec }
487 cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
488 ; sec <- returnL $ SectionL x' s'
489 ; return $ HsPar sec }
490 cvt (InfixE Nothing s Nothing ) = cvt s -- Can I indicate this is an infix thing?
492 cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t
493 ; return $ ExprWithTySig e' t' }
494 cvt (RecConE c flds) = do { c' <- cNameL c
495 ; flds' <- mapM cvtFld flds
496 ; return $ RecordCon c' noPostTcExpr (HsRecFields flds' Nothing)}
497 cvt (RecUpdE e flds) = do { e' <- cvtl e
498 ; flds' <- mapM cvtFld flds
499 ; return $ RecordUpd e' (HsRecFields flds' Nothing) [] [] [] }
501 cvtFld :: (TH.Name, TH.Exp) -> CvtM (HsRecField RdrName (LHsExpr RdrName))
503 = do { v' <- vNameL v; e' <- cvtl e
504 ; return (HsRecField { hsRecFieldId = v', hsRecFieldArg = e', hsRecPun = False}) }
506 cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)
507 cvtDD (FromR x) = do { x' <- cvtl x; return $ From x' }
508 cvtDD (FromThenR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }
509 cvtDD (FromToR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
510 cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }
512 -------------------------------------
513 -- Do notation and statements
514 -------------------------------------
516 cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr RdrName)
517 cvtHsDo do_or_lc stmts
518 | null stmts = failWith (ptext (sLit "Empty stmt list in do-block"))
520 = do { stmts' <- cvtStmts stmts
521 ; body <- case last stmts' of
522 L _ (ExprStmt body _ _) -> return body
523 stmt' -> failWith (bad_last stmt')
524 ; return $ HsDo do_or_lc (init stmts') body void }
526 bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprStmtContext do_or_lc <> colon
527 , nest 2 $ Outputable.ppr stmt
528 , ptext (sLit "(It should be an expression.)") ]
530 cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName]
531 cvtStmts = mapM cvtStmt
533 cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName)
534 cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkExprStmt e' }
535 cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
536 cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (ptext (sLit "a let binding")) ds
537 ; returnL $ LetStmt ds' }
538 cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' }
540 cvt_one ds = do { ds' <- cvtStmts ds; return (ds', undefined) }
542 cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName)
543 cvtMatch (TH.Match p body decs)
544 = do { p' <- cvtPat p
545 ; g' <- cvtGuard body
546 ; decs' <- cvtLocalDecs (ptext (sLit "a where clause")) decs
547 ; returnL $ Hs.Match [p'] Nothing (GRHSs g' decs') }
549 cvtGuard :: TH.Body -> CvtM [LGRHS RdrName]
550 cvtGuard (GuardedB pairs) = mapM cvtpair pairs
551 cvtGuard (NormalB e) = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] }
553 cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName)
554 cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
555 ; g' <- returnL $ mkExprStmt ge'
556 ; returnL $ GRHS [g'] rhs' }
557 cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
558 ; returnL $ GRHS gs' rhs' }
560 cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
561 cvtOverLit (IntegerL i)
562 = do { force i; return $ mkHsIntegral i placeHolderType}
563 cvtOverLit (RationalL r)
564 = do { force r; return $ mkHsFractional r placeHolderType}
565 cvtOverLit (StringL s)
566 = do { let { s' = mkFastString s }
568 ; return $ mkHsIsString s' placeHolderType
570 cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
571 -- An Integer is like an (overloaded) '3' in a Haskell source program
572 -- Similarly 3.5 for fractionals
574 {- Note [Converting strings]
575 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
576 If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to
577 a string literal for "xy". Of course, we might hope to get
578 (LitE (StringL "xy")), but not always, and allCharLs fails quickly
579 if it isn't a literal string
582 allCharLs :: [TH.Exp] -> Maybe String
583 -- Note [Converting strings]
584 -- NB: only fire up this setup for a non-empty list, else
585 -- there's a danger of returning "" for [] :: [Int]!
588 LitE (CharL c) : ys -> go [c] ys
591 go cs [] = Just (reverse cs)
592 go cs (LitE (CharL c) : ys) = go (c:cs) ys
595 cvtLit :: Lit -> CvtM HsLit
596 cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim i }
597 cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim w }
598 cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim f }
599 cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim f }
600 cvtLit (CharL c) = do { force c; return $ HsChar c }
601 cvtLit (StringL s) = do { let { s' = mkFastString s }
603 ; return $ HsString s' }
604 cvtLit (StringPrimL s) = do { let { s' = mkFastString s }
606 ; return $ HsStringPrim s' }
607 cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
608 -- cvtLit should not be called on IntegerL, RationalL
609 -- That precondition is established right here in
610 -- Convert.lhs, hence panic
612 cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName]
613 cvtPats pats = mapM cvtPat pats
615 cvtPat :: TH.Pat -> CvtM (Hs.LPat RdrName)
616 cvtPat pat = wrapL (cvtp pat)
618 cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName)
620 | overloadedLit l = do { l' <- cvtOverLit l
621 ; return (mkNPat l' Nothing) }
622 -- Not right for negative patterns;
623 -- need to think about that!
624 | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat l' }
625 cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat s' }
626 cvtp (TupP [p]) = cvtp p
627 cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void }
628 cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps; return $ ConPatIn s' (PrefixCon ps') }
629 cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
630 ; return $ ConPatIn s' (InfixCon p1' p2') }
631 cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat p' }
632 cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat p' }
633 cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
634 cvtp TH.WildP = return $ WildPat void
635 cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
636 ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
637 cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void }
638 cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' }
640 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
642 = do { s' <- vNameL s; p' <- cvtPat p
643 ; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) }
645 -----------------------------------------------------------
646 -- Types and type variables
648 cvtTvs :: [TH.TyVarBndr] -> CvtM [LHsTyVarBndr RdrName]
649 cvtTvs tvs = mapM cvt_tv tvs
651 cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
652 cvt_tv (TH.PlainTV nm)
653 = do { nm' <- tName nm
654 ; returnL $ UserTyVar nm' placeHolderKind
656 cvt_tv (TH.KindedTV nm ki)
657 = do { nm' <- tName nm
658 ; returnL $ KindedTyVar nm' (cvtKind ki)
661 cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
662 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
664 cvtPred :: TH.Pred -> CvtM (LHsPred RdrName)
665 cvtPred (TH.ClassP cla tys)
666 = do { cla' <- if isVarName cla then tName cla else tconName cla
667 ; tys' <- mapM cvtType tys
668 ; returnL $ HsClassP cla' tys'
670 cvtPred (TH.EqualP ty1 ty2)
671 = do { ty1' <- cvtType ty1
672 ; ty2' <- cvtType ty2
673 ; returnL $ HsEqualP ty1' ty2'
676 cvtPredTy :: TH.Type -> CvtM (LHsPred RdrName)
678 = do { (head, tys') <- split_ty_app ty
680 ConT tc -> do { tc' <- tconName tc; returnL $ HsClassP tc' tys' }
681 VarT tv -> do { tv' <- tName tv; returnL $ HsClassP tv' tys' }
682 _ -> failWith (ptext (sLit "Malformed predicate") <+>
683 text (TH.pprint ty)) }
685 cvtType :: TH.Type -> CvtM (LHsType RdrName)
687 = do { (head_ty, tys') <- split_ty_app ty
690 | length tys' == n -- Saturated
691 -> if n==1 then return (head tys') -- Singleton tuples treated
692 -- like nothing (ie just parens)
693 else returnL (HsTupleTy Boxed tys')
695 -> failWith (ptext (sLit "Illegal 1-tuple type constructor"))
697 -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys'
699 | [x',y'] <- tys' -> returnL (HsFunTy x' y')
700 | otherwise -> mk_apps (HsTyVar (getRdrName funTyCon)) tys'
702 | [x'] <- tys' -> returnL (HsListTy x')
703 | otherwise -> mk_apps (HsTyVar (getRdrName listTyCon)) tys'
704 VarT nm -> do { nm' <- tName nm; mk_apps (HsTyVar nm') tys' }
705 ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' }
709 -> do { tvs' <- cvtTvs tvs
710 ; cxt' <- cvtContext cxt
712 ; returnL $ mkExplicitHsForAllTy tvs' cxt' ty'
716 -> do { ty' <- cvtType ty
717 ; mk_apps (HsKindSig ty' (cvtKind ki)) tys'
720 _ -> failWith (ptext (sLit "Malformed type") <+> text (show ty))
723 mk_apps head_ty [] = returnL head_ty
724 mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
725 ; mk_apps (HsAppTy head_ty' ty) tys }
727 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
728 split_ty_app ty = go ty []
730 go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
731 go f as = return (f,as)
733 cvtKind :: TH.Kind -> Type.Kind
734 cvtKind StarK = liftedTypeKind
735 cvtKind (ArrowK k1 k2) = mkArrowKind (cvtKind k1) (cvtKind k2)
737 -----------------------------------------------------------
740 -----------------------------------------------------------
741 -- some useful things
743 overloadedLit :: Lit -> Bool
744 -- True for literals that Haskell treats as overloaded
745 overloadedLit (IntegerL _) = True
746 overloadedLit (RationalL _) = True
747 overloadedLit _ = False
750 void = placeHolderType
752 --------------------------------------------------------------------
753 -- Turning Name back into RdrName
754 --------------------------------------------------------------------
757 vNameL, cNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
758 vName, cName, tName, tconName :: TH.Name -> CvtM RdrName
760 vNameL n = wrapL (vName n)
761 vName n = cvtName OccName.varName n
763 -- Constructor function names; this is Haskell source, hence srcDataName
764 cNameL n = wrapL (cName n)
765 cName n = cvtName OccName.dataName n
767 -- Type variable names
768 tName n = cvtName OccName.tvName n
770 -- Type Constructor names
771 tconNameL n = wrapL (tconName n)
772 tconName n = cvtName OccName.tcClsName n
774 cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
775 cvtName ctxt_ns (TH.Name occ flavour)
776 | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
777 | otherwise = force rdr_name >> return rdr_name
779 occ_str = TH.occString occ
780 rdr_name = thRdrName ctxt_ns occ_str flavour
782 okOcc :: OccName.NameSpace -> String -> Bool
785 | OccName.isVarNameSpace ns = startsVarId c || startsVarSym c
786 | otherwise = startsConId c || startsConSym c || str == "[]"
788 -- Determine the name space of a name in a type
790 isVarName :: TH.Name -> Bool
791 isVarName (TH.Name occ _)
792 = case TH.occString occ of
794 (c:_) -> startsVarId c || startsVarSym c
796 badOcc :: OccName.NameSpace -> String -> SDoc
798 = ptext (sLit "Illegal") <+> pprNameSpace ctxt_ns
799 <+> ptext (sLit "name:") <+> quotes (text occ)
801 thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
802 -- This turns a Name into a RdrName
803 -- The passed-in name space tells what the context is expecting;
804 -- use it unless the TH name knows what name-space it comes
805 -- from, in which case use the latter
807 -- ToDo: we may generate silly RdrNames, by passing a name space
808 -- that doesn't match the string, like VarName ":+",
809 -- which will give confusing error messages later
811 -- The strict applications ensure that any buried exceptions get forced
812 thRdrName _ occ (TH.NameG th_ns pkg mod) = thOrigRdrName occ th_ns pkg mod
813 thRdrName ctxt_ns occ (TH.NameL uniq) = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcSpan)
814 thRdrName ctxt_ns occ (TH.NameQ mod) = (mkRdrQual $! (mk_mod mod)) $! (mk_occ ctxt_ns occ)
815 thRdrName ctxt_ns occ (TH.NameU uniq) = mkRdrUnqual $! (mk_uniq_occ ctxt_ns occ uniq)
816 thRdrName ctxt_ns occ TH.NameS
817 | Just name <- isBuiltInOcc ctxt_ns occ = nameRdrName $! name
818 | otherwise = mkRdrUnqual $! (mk_occ ctxt_ns occ)
820 thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
821 thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)
823 thRdrNameGuesses :: TH.Name -> [RdrName]
824 thRdrNameGuesses (TH.Name occ flavour)
825 -- This special case for NameG ensures that we don't generate duplicates in the output list
826 | TH.NameG th_ns pkg mod <- flavour = [thOrigRdrName occ_str th_ns pkg mod]
827 | otherwise = [ thRdrName gns occ_str flavour
828 | gns <- guessed_nss]
830 -- guessed_ns are the name spaces guessed from looking at the TH name
831 guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName, OccName.dataName]
832 | otherwise = [OccName.varName, OccName.tvName]
833 occ_str = TH.occString occ
835 isBuiltInOcc :: OccName.NameSpace -> String -> Maybe Name.Name
836 -- Built in syntax isn't "in scope" so an Unqual RdrName won't do
837 -- We must generate an Exact name, just as the parser does
838 isBuiltInOcc ctxt_ns occ
840 ":" -> Just (Name.getName consDataCon)
841 "[]" -> Just (Name.getName nilDataCon)
842 "()" -> Just (tup_name 0)
843 '(' : ',' : rest -> go_tuple 2 rest
846 go_tuple n ")" = Just (tup_name n)
847 go_tuple n (',' : rest) = go_tuple (n+1) rest
848 go_tuple _ _ = Nothing
851 | OccName.isTcClsNameSpace ctxt_ns = Name.getName (tupleTyCon Boxed n)
852 | otherwise = Name.getName (tupleCon Boxed n)
854 mk_uniq_occ :: OccName.NameSpace -> String -> Int# -> OccName.OccName
855 mk_uniq_occ ns occ uniq
856 = OccName.mkOccName ns (occ ++ '[' : shows (mk_uniq uniq) "]")
857 -- See Note [Unique OccNames from Template Haskell]
859 -- The packing and unpacking is rather turgid :-(
860 mk_occ :: OccName.NameSpace -> String -> OccName.OccName
861 mk_occ ns occ = OccName.mkOccNameFS ns (mkFastString occ)
863 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
864 mk_ghc_ns TH.DataName = OccName.dataName
865 mk_ghc_ns TH.TcClsName = OccName.tcClsName
866 mk_ghc_ns TH.VarName = OccName.varName
868 mk_mod :: TH.ModName -> ModuleName
869 mk_mod mod = mkModuleName (TH.modString mod)
871 mk_pkg :: TH.PkgName -> PackageId
872 mk_pkg pkg = stringToPackageId (TH.pkgString pkg)
874 mk_uniq :: Int# -> Unique
875 mk_uniq u = mkUniqueGrimily (I# u)
878 Note [Unique OccNames from Template Haskell]
879 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
880 The idea here is to make a name that
881 a) the user could not possibly write (it has a "["
882 and letters or digits from the unique)
883 b) cannot clash with another NameU
884 Previously I generated an Exact RdrName with mkInternalName. This
885 works fine for local binders, but does not work at all for top-level
886 binders, which must have External Names, since they are rapidly baked
887 into data constructors and the like. Baling out and generating an
888 unqualified RdrName here is the simple solution
890 See also Note [Suppressing uniques in OccNames] in OccName, which
891 suppresses the unique when opt_SuppressUniques is on.