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
378 Interruptible -> PlayInterruptible
380 cvtForD (ExportF callconv as nm ty)
381 = do { nm' <- vNameL nm
383 ; let e = CExport (CExportStatic (mkFastString as) (cvt_conv callconv))
384 ; return $ ForeignExport nm' ty' e }
386 cvt_conv :: TH.Callconv -> CCallConv
387 cvt_conv TH.CCall = CCallConv
388 cvt_conv TH.StdCall = StdCallConv
390 ------------------------------------------
392 ------------------------------------------
394 cvtPragmaD :: Pragma -> CvtM (Sig RdrName)
395 cvtPragmaD (InlineP nm ispec)
396 = do { nm' <- vNameL nm
397 ; return $ InlineSig nm' (cvtInlineSpec (Just ispec)) }
399 cvtPragmaD (SpecialiseP nm ty opt_ispec)
400 = do { nm' <- vNameL nm
402 ; return $ SpecSig nm' ty' (cvtInlineSpec opt_ispec) }
404 cvtInlineSpec :: Maybe TH.InlineSpec -> Hs.InlinePragma
405 cvtInlineSpec Nothing
406 = defaultInlinePragma
407 cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation))
408 = InlinePragma { inl_act = opt_activation', inl_rule = matchinfo
409 , inl_inline = inl_spec, inl_sat = Nothing }
411 matchinfo = cvtRuleMatchInfo conlike
412 opt_activation' = cvtActivation opt_activation
414 cvtRuleMatchInfo False = FunLike
415 cvtRuleMatchInfo True = ConLike
417 inl_spec | inline = Inline
418 | otherwise = NoInline
419 -- Currently we have no way to say Inlinable
421 cvtActivation Nothing | inline = AlwaysActive
422 | otherwise = NeverActive
423 cvtActivation (Just (False, phase)) = ActiveBefore phase
424 cvtActivation (Just (True , phase)) = ActiveAfter phase
426 ---------------------------------------------------
428 ---------------------------------------------------
430 cvtLocalDecs :: Message -> [TH.Dec] -> CvtM (HsLocalBinds RdrName)
433 = return EmptyLocalBinds
435 = do { ds' <- mapM cvtDec ds
436 ; let (binds, prob_sigs) = partitionWith is_bind ds'
437 ; let (sigs, bads) = partitionWith is_sig prob_sigs
438 ; unless (null bads) (failWith (mkBadDecMsg doc bads))
439 ; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) }
441 cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName)
442 cvtClause (Clause ps body wheres)
443 = do { ps' <- cvtPats ps
444 ; g' <- cvtGuard body
445 ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) wheres
446 ; returnL $ Hs.Match ps' Nothing (GRHSs g' ds') }
449 -------------------------------------------------------------------
451 -------------------------------------------------------------------
453 cvtl :: TH.Exp -> CvtM (LHsExpr RdrName)
454 cvtl e = wrapL (cvt e)
456 cvt (VarE s) = do { s' <- vName s; return $ HsVar s' }
457 cvt (ConE s) = do { s' <- cName s; return $ HsVar s' }
459 | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }
460 | otherwise = do { l' <- cvtLit l; return $ HsLit l' }
462 cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' }
463 cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e
464 ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) }
465 cvt (TupE [e]) = cvt e -- Singleton tuples treated like nothing (just parens)
466 cvt (TupE es) = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Boxed }
467 cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
468 ; return $ HsIf (Just noSyntaxExpr) x' y' z' }
469 cvt (LetE ds e) = do { ds' <- cvtLocalDecs (ptext (sLit "a let expression")) ds
470 ; e' <- cvtl e; return $ HsLet ds' e' }
472 | null ms = failWith (ptext (sLit "Case expression with no alternatives"))
473 | otherwise = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
474 ; return $ HsCase e' (mkMatchGroup ms') }
475 cvt (DoE ss) = cvtHsDo DoExpr ss
476 cvt (CompE ss) = cvtHsDo ListComp ss
477 cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr dd' }
479 | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s); return (HsLit l') }
480 -- Note [Converting strings]
481 | otherwise = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' }
482 cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
483 ; e' <- returnL $ OpApp x' s' undefined y'
484 ; return $ HsPar e' }
485 cvt (InfixE Nothing s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
486 ; sec <- returnL $ SectionR s' y'
487 ; return $ HsPar sec }
488 cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
489 ; sec <- returnL $ SectionL x' s'
490 ; return $ HsPar sec }
491 cvt (InfixE Nothing s Nothing ) = cvt s -- Can I indicate this is an infix thing?
493 cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t
494 ; return $ ExprWithTySig e' t' }
495 cvt (RecConE c flds) = do { c' <- cNameL c
496 ; flds' <- mapM cvtFld flds
497 ; return $ RecordCon c' noPostTcExpr (HsRecFields flds' Nothing)}
498 cvt (RecUpdE e flds) = do { e' <- cvtl e
499 ; flds' <- mapM cvtFld flds
500 ; return $ RecordUpd e' (HsRecFields flds' Nothing) [] [] [] }
502 cvtFld :: (TH.Name, TH.Exp) -> CvtM (HsRecField RdrName (LHsExpr RdrName))
504 = do { v' <- vNameL v; e' <- cvtl e
505 ; return (HsRecField { hsRecFieldId = v', hsRecFieldArg = e', hsRecPun = False}) }
507 cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)
508 cvtDD (FromR x) = do { x' <- cvtl x; return $ From x' }
509 cvtDD (FromThenR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }
510 cvtDD (FromToR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
511 cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }
513 -------------------------------------
514 -- Do notation and statements
515 -------------------------------------
517 cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr RdrName)
518 cvtHsDo do_or_lc stmts
519 | null stmts = failWith (ptext (sLit "Empty stmt list in do-block"))
521 = do { stmts' <- cvtStmts stmts
522 ; body <- case last stmts' of
523 L _ (ExprStmt body _ _) -> return body
524 stmt' -> failWith (bad_last stmt')
525 ; return $ HsDo do_or_lc (init stmts') body void }
527 bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprStmtContext do_or_lc <> colon
528 , nest 2 $ Outputable.ppr stmt
529 , ptext (sLit "(It should be an expression.)") ]
531 cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName]
532 cvtStmts = mapM cvtStmt
534 cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName)
535 cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkExprStmt e' }
536 cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
537 cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (ptext (sLit "a let binding")) ds
538 ; returnL $ LetStmt ds' }
539 cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' }
541 cvt_one ds = do { ds' <- cvtStmts ds; return (ds', undefined) }
543 cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName)
544 cvtMatch (TH.Match p body decs)
545 = do { p' <- cvtPat p
546 ; g' <- cvtGuard body
547 ; decs' <- cvtLocalDecs (ptext (sLit "a where clause")) decs
548 ; returnL $ Hs.Match [p'] Nothing (GRHSs g' decs') }
550 cvtGuard :: TH.Body -> CvtM [LGRHS RdrName]
551 cvtGuard (GuardedB pairs) = mapM cvtpair pairs
552 cvtGuard (NormalB e) = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] }
554 cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName)
555 cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
556 ; g' <- returnL $ mkExprStmt ge'
557 ; returnL $ GRHS [g'] rhs' }
558 cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
559 ; returnL $ GRHS gs' rhs' }
561 cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
562 cvtOverLit (IntegerL i)
563 = do { force i; return $ mkHsIntegral i placeHolderType}
564 cvtOverLit (RationalL r)
565 = do { force r; return $ mkHsFractional r placeHolderType}
566 cvtOverLit (StringL s)
567 = do { let { s' = mkFastString s }
569 ; return $ mkHsIsString s' placeHolderType
571 cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
572 -- An Integer is like an (overloaded) '3' in a Haskell source program
573 -- Similarly 3.5 for fractionals
575 {- Note [Converting strings]
576 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
577 If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to
578 a string literal for "xy". Of course, we might hope to get
579 (LitE (StringL "xy")), but not always, and allCharLs fails quickly
580 if it isn't a literal string
583 allCharLs :: [TH.Exp] -> Maybe String
584 -- Note [Converting strings]
585 -- NB: only fire up this setup for a non-empty list, else
586 -- there's a danger of returning "" for [] :: [Int]!
589 LitE (CharL c) : ys -> go [c] ys
592 go cs [] = Just (reverse cs)
593 go cs (LitE (CharL c) : ys) = go (c:cs) ys
596 cvtLit :: Lit -> CvtM HsLit
597 cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim i }
598 cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim w }
599 cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim f }
600 cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim f }
601 cvtLit (CharL c) = do { force c; return $ HsChar c }
602 cvtLit (StringL s) = do { let { s' = mkFastString s }
604 ; return $ HsString s' }
605 cvtLit (StringPrimL s) = do { let { s' = mkFastString s }
607 ; return $ HsStringPrim s' }
608 cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
609 -- cvtLit should not be called on IntegerL, RationalL
610 -- That precondition is established right here in
611 -- Convert.lhs, hence panic
613 cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName]
614 cvtPats pats = mapM cvtPat pats
616 cvtPat :: TH.Pat -> CvtM (Hs.LPat RdrName)
617 cvtPat pat = wrapL (cvtp pat)
619 cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName)
621 | overloadedLit l = do { l' <- cvtOverLit l
622 ; return (mkNPat l' Nothing) }
623 -- Not right for negative patterns;
624 -- need to think about that!
625 | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat l' }
626 cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat s' }
627 cvtp (TupP [p]) = cvtp p
628 cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void }
629 cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps; return $ ConPatIn s' (PrefixCon ps') }
630 cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
631 ; return $ ConPatIn s' (InfixCon p1' p2') }
632 cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat p' }
633 cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat p' }
634 cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
635 cvtp TH.WildP = return $ WildPat void
636 cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
637 ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
638 cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void }
639 cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' }
640 cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p; return $ ViewPat e' p' void }
642 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
644 = do { s' <- vNameL s; p' <- cvtPat p
645 ; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) }
647 -----------------------------------------------------------
648 -- Types and type variables
650 cvtTvs :: [TH.TyVarBndr] -> CvtM [LHsTyVarBndr RdrName]
651 cvtTvs tvs = mapM cvt_tv tvs
653 cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
654 cvt_tv (TH.PlainTV nm)
655 = do { nm' <- tName nm
656 ; returnL $ UserTyVar nm' placeHolderKind
658 cvt_tv (TH.KindedTV nm ki)
659 = do { nm' <- tName nm
660 ; returnL $ KindedTyVar nm' (cvtKind ki)
663 cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
664 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
666 cvtPred :: TH.Pred -> CvtM (LHsPred RdrName)
667 cvtPred (TH.ClassP cla tys)
668 = do { cla' <- if isVarName cla then tName cla else tconName cla
669 ; tys' <- mapM cvtType tys
670 ; returnL $ HsClassP cla' tys'
672 cvtPred (TH.EqualP ty1 ty2)
673 = do { ty1' <- cvtType ty1
674 ; ty2' <- cvtType ty2
675 ; returnL $ HsEqualP ty1' ty2'
678 cvtPredTy :: TH.Type -> CvtM (LHsPred RdrName)
680 = do { (head, tys') <- split_ty_app ty
682 ConT tc -> do { tc' <- tconName tc; returnL $ HsClassP tc' tys' }
683 VarT tv -> do { tv' <- tName tv; returnL $ HsClassP tv' tys' }
684 _ -> failWith (ptext (sLit "Malformed predicate") <+>
685 text (TH.pprint ty)) }
687 cvtType :: TH.Type -> CvtM (LHsType RdrName)
689 = do { (head_ty, tys') <- split_ty_app ty
692 | length tys' == n -- Saturated
693 -> if n==1 then return (head tys') -- Singleton tuples treated
694 -- like nothing (ie just parens)
695 else returnL (HsTupleTy Boxed tys')
697 -> failWith (ptext (sLit "Illegal 1-tuple type constructor"))
699 -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys'
701 | [x',y'] <- tys' -> returnL (HsFunTy x' y')
702 | otherwise -> mk_apps (HsTyVar (getRdrName funTyCon)) tys'
704 | [x'] <- tys' -> returnL (HsListTy x')
705 | otherwise -> mk_apps (HsTyVar (getRdrName listTyCon)) tys'
706 VarT nm -> do { nm' <- tName nm; mk_apps (HsTyVar nm') tys' }
707 ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' }
711 -> do { tvs' <- cvtTvs tvs
712 ; cxt' <- cvtContext cxt
714 ; returnL $ mkExplicitHsForAllTy tvs' cxt' ty'
718 -> do { ty' <- cvtType ty
719 ; mk_apps (HsKindSig ty' (cvtKind ki)) tys'
722 _ -> failWith (ptext (sLit "Malformed type") <+> text (show ty))
725 mk_apps head_ty [] = returnL head_ty
726 mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
727 ; mk_apps (HsAppTy head_ty' ty) tys }
729 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
730 split_ty_app ty = go ty []
732 go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
733 go f as = return (f,as)
735 cvtKind :: TH.Kind -> Type.Kind
736 cvtKind StarK = liftedTypeKind
737 cvtKind (ArrowK k1 k2) = mkArrowKind (cvtKind k1) (cvtKind k2)
739 -----------------------------------------------------------
742 -----------------------------------------------------------
743 -- some useful things
745 overloadedLit :: Lit -> Bool
746 -- True for literals that Haskell treats as overloaded
747 overloadedLit (IntegerL _) = True
748 overloadedLit (RationalL _) = True
749 overloadedLit _ = False
752 void = placeHolderType
754 --------------------------------------------------------------------
755 -- Turning Name back into RdrName
756 --------------------------------------------------------------------
759 vNameL, cNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
760 vName, cName, tName, tconName :: TH.Name -> CvtM RdrName
762 vNameL n = wrapL (vName n)
763 vName n = cvtName OccName.varName n
765 -- Constructor function names; this is Haskell source, hence srcDataName
766 cNameL n = wrapL (cName n)
767 cName n = cvtName OccName.dataName n
769 -- Type variable names
770 tName n = cvtName OccName.tvName n
772 -- Type Constructor names
773 tconNameL n = wrapL (tconName n)
774 tconName n = cvtName OccName.tcClsName n
776 cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
777 cvtName ctxt_ns (TH.Name occ flavour)
778 | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
779 | otherwise = force rdr_name >> return rdr_name
781 occ_str = TH.occString occ
782 rdr_name = thRdrName ctxt_ns occ_str flavour
784 okOcc :: OccName.NameSpace -> String -> Bool
787 | OccName.isVarNameSpace ns = startsVarId c || startsVarSym c
788 | otherwise = startsConId c || startsConSym c || str == "[]"
790 -- Determine the name space of a name in a type
792 isVarName :: TH.Name -> Bool
793 isVarName (TH.Name occ _)
794 = case TH.occString occ of
796 (c:_) -> startsVarId c || startsVarSym c
798 badOcc :: OccName.NameSpace -> String -> SDoc
800 = ptext (sLit "Illegal") <+> pprNameSpace ctxt_ns
801 <+> ptext (sLit "name:") <+> quotes (text occ)
803 thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
804 -- This turns a Name into a RdrName
805 -- The passed-in name space tells what the context is expecting;
806 -- use it unless the TH name knows what name-space it comes
807 -- from, in which case use the latter
809 -- ToDo: we may generate silly RdrNames, by passing a name space
810 -- that doesn't match the string, like VarName ":+",
811 -- which will give confusing error messages later
813 -- The strict applications ensure that any buried exceptions get forced
814 thRdrName _ occ (TH.NameG th_ns pkg mod) = thOrigRdrName occ th_ns pkg mod
815 thRdrName ctxt_ns occ (TH.NameL uniq) = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcSpan)
816 thRdrName ctxt_ns occ (TH.NameQ mod) = (mkRdrQual $! (mk_mod mod)) $! (mk_occ ctxt_ns occ)
817 thRdrName ctxt_ns occ (TH.NameU uniq) = mkRdrUnqual $! (mk_uniq_occ ctxt_ns occ uniq)
818 thRdrName ctxt_ns occ TH.NameS
819 | Just name <- isBuiltInOcc ctxt_ns occ = nameRdrName $! name
820 | otherwise = mkRdrUnqual $! (mk_occ ctxt_ns occ)
822 thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
823 thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)
825 thRdrNameGuesses :: TH.Name -> [RdrName]
826 thRdrNameGuesses (TH.Name occ flavour)
827 -- This special case for NameG ensures that we don't generate duplicates in the output list
828 | TH.NameG th_ns pkg mod <- flavour = [thOrigRdrName occ_str th_ns pkg mod]
829 | otherwise = [ thRdrName gns occ_str flavour
830 | gns <- guessed_nss]
832 -- guessed_ns are the name spaces guessed from looking at the TH name
833 guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName, OccName.dataName]
834 | otherwise = [OccName.varName, OccName.tvName]
835 occ_str = TH.occString occ
837 isBuiltInOcc :: OccName.NameSpace -> String -> Maybe Name.Name
838 -- Built in syntax isn't "in scope" so an Unqual RdrName won't do
839 -- We must generate an Exact name, just as the parser does
840 isBuiltInOcc ctxt_ns occ
842 ":" -> Just (Name.getName consDataCon)
843 "[]" -> Just (Name.getName nilDataCon)
844 "()" -> Just (tup_name 0)
845 '(' : ',' : rest -> go_tuple 2 rest
848 go_tuple n ")" = Just (tup_name n)
849 go_tuple n (',' : rest) = go_tuple (n+1) rest
850 go_tuple _ _ = Nothing
853 | OccName.isTcClsNameSpace ctxt_ns = Name.getName (tupleTyCon Boxed n)
854 | otherwise = Name.getName (tupleCon Boxed n)
856 mk_uniq_occ :: OccName.NameSpace -> String -> Int# -> OccName.OccName
857 mk_uniq_occ ns occ uniq
858 = OccName.mkOccName ns (occ ++ '[' : shows (mk_uniq uniq) "]")
859 -- See Note [Unique OccNames from Template Haskell]
861 -- The packing and unpacking is rather turgid :-(
862 mk_occ :: OccName.NameSpace -> String -> OccName.OccName
863 mk_occ ns occ = OccName.mkOccNameFS ns (mkFastString occ)
865 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
866 mk_ghc_ns TH.DataName = OccName.dataName
867 mk_ghc_ns TH.TcClsName = OccName.tcClsName
868 mk_ghc_ns TH.VarName = OccName.varName
870 mk_mod :: TH.ModName -> ModuleName
871 mk_mod mod = mkModuleName (TH.modString mod)
873 mk_pkg :: TH.PkgName -> PackageId
874 mk_pkg pkg = stringToPackageId (TH.pkgString pkg)
876 mk_uniq :: Int# -> Unique
877 mk_uniq u = mkUniqueGrimily (I# u)
880 Note [Unique OccNames from Template Haskell]
881 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
882 The idea here is to make a name that
883 a) the user could not possibly write (it has a "["
884 and letters or digits from the unique)
885 b) cannot clash with another NameU
886 Previously I generated an Exact RdrName with mkInternalName. This
887 works fine for local binders, but does not work at all for top-level
888 binders, which must have External Names, since they are rapidly baked
889 into data constructors and the like. Baling out and generating an
890 unqualified RdrName here is the simple solution
892 See also Note [Suppressing uniques in OccNames] in OccName, which
893 suppresses the unique when opt_SuppressUniques is on.