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 (UnboxedTupleT _) = return []
272 collect ArrowT = return []
273 collect ListT = return []
275 = do { tvs1 <- collect t1
277 ; return $ tvs1 ++ tvs2
279 collect (SigT (VarT tv) ki) = return [KindedTV tv ki]
280 collect (SigT ty _) = collect ty
282 -------------------------------------------------------------------
283 -- Partitioning declarations
284 -------------------------------------------------------------------
286 is_tycl :: LHsDecl RdrName -> Either (LTyClDecl RdrName) (LHsDecl RdrName)
287 is_tycl (L loc (Hs.TyClD tcd)) = Left (L loc tcd)
288 is_tycl decl = Right decl
290 is_sig :: LHsDecl RdrName -> Either (LSig RdrName) (LHsDecl RdrName)
291 is_sig (L loc (Hs.SigD sig)) = Left (L loc sig)
292 is_sig decl = Right decl
294 is_bind :: LHsDecl RdrName -> Either (LHsBind RdrName) (LHsDecl RdrName)
295 is_bind (L loc (Hs.ValD bind)) = Left (L loc bind)
296 is_bind decl = Right decl
298 mkBadDecMsg :: Message -> [LHsDecl RdrName] -> Message
300 = sep [ ptext (sLit "Illegal declaration(s) in") <+> doc <> colon
301 , nest 2 (vcat (map Outputable.ppr bads)) ]
303 ---------------------------------------------------
305 -- Can't handle GADTs yet
306 ---------------------------------------------------
308 cvtConstr :: TH.Con -> CvtM (LConDecl RdrName)
310 cvtConstr (NormalC c strtys)
311 = do { c' <- cNameL c
313 ; tys' <- mapM cvt_arg strtys
314 ; returnL $ mkSimpleConDecl c' noExistentials cxt' (PrefixCon tys') }
316 cvtConstr (RecC c varstrtys)
317 = do { c' <- cNameL c
319 ; args' <- mapM cvt_id_arg varstrtys
320 ; returnL $ mkSimpleConDecl c' noExistentials cxt' (RecCon args') }
322 cvtConstr (InfixC st1 c st2)
323 = do { c' <- cNameL c
325 ; st1' <- cvt_arg st1
326 ; st2' <- cvt_arg st2
327 ; returnL $ mkSimpleConDecl c' noExistentials cxt' (InfixCon st1' st2') }
329 cvtConstr (ForallC tvs ctxt con)
330 = do { tvs' <- cvtTvs tvs
331 ; L loc ctxt' <- cvtContext ctxt
332 ; L _ con' <- cvtConstr con
333 ; returnL $ con' { con_qvars = tvs' ++ con_qvars con'
334 , con_cxt = L loc (ctxt' ++ (unLoc $ con_cxt con')) } }
336 cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
337 cvt_arg (IsStrict, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy HsStrict ty' }
338 cvt_arg (NotStrict, ty) = cvtType ty
340 cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (ConDeclField RdrName)
341 cvt_id_arg (i, str, ty)
342 = do { i' <- vNameL i
343 ; ty' <- cvt_arg (str,ty)
344 ; return (ConDeclField { cd_fld_name = i', cd_fld_type = ty', cd_fld_doc = Nothing}) }
346 cvtDerivs :: [TH.Name] -> CvtM (Maybe [LHsType RdrName])
347 cvtDerivs [] = return Nothing
348 cvtDerivs cs = do { cs' <- mapM cvt_one cs
349 ; return (Just cs') }
351 cvt_one c = do { c' <- tconName c
352 ; returnL $ HsPredTy $ HsClassP c' [] }
354 cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep RdrName))
355 cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs; ys' <- mapM tName ys; returnL (xs', ys') }
357 noExistentials :: [LHsTyVarBndr RdrName]
360 ------------------------------------------
361 -- Foreign declarations
362 ------------------------------------------
364 cvtForD :: Foreign -> CvtM (ForeignDecl RdrName)
365 cvtForD (ImportF callconv safety from nm ty)
366 | Just impspec <- parseCImport (cvt_conv callconv) safety'
367 (mkFastString (TH.nameBase nm)) from
368 = do { nm' <- vNameL nm
370 ; return (ForeignImport nm' ty' impspec)
373 = failWith $ text (show from) <+> ptext (sLit "is not a valid ccall impent")
375 safety' = case safety of
377 Safe -> PlaySafe False
378 Threadsafe -> PlaySafe True
379 Interruptible -> PlayInterruptible
381 cvtForD (ExportF callconv as nm ty)
382 = do { nm' <- vNameL nm
384 ; let e = CExport (CExportStatic (mkFastString as) (cvt_conv callconv))
385 ; return $ ForeignExport nm' ty' e }
387 cvt_conv :: TH.Callconv -> CCallConv
388 cvt_conv TH.CCall = CCallConv
389 cvt_conv TH.StdCall = StdCallConv
391 ------------------------------------------
393 ------------------------------------------
395 cvtPragmaD :: Pragma -> CvtM (Sig RdrName)
396 cvtPragmaD (InlineP nm ispec)
397 = do { nm' <- vNameL nm
398 ; return $ InlineSig nm' (cvtInlineSpec (Just ispec)) }
400 cvtPragmaD (SpecialiseP nm ty opt_ispec)
401 = do { nm' <- vNameL nm
403 ; return $ SpecSig nm' ty' (cvtInlineSpec opt_ispec) }
405 cvtInlineSpec :: Maybe TH.InlineSpec -> Hs.InlinePragma
406 cvtInlineSpec Nothing
407 = defaultInlinePragma
408 cvtInlineSpec (Just (TH.InlineSpec inline conlike opt_activation))
409 = InlinePragma { inl_act = opt_activation', inl_rule = matchinfo
410 , inl_inline = inl_spec, inl_sat = Nothing }
412 matchinfo = cvtRuleMatchInfo conlike
413 opt_activation' = cvtActivation opt_activation
415 cvtRuleMatchInfo False = FunLike
416 cvtRuleMatchInfo True = ConLike
418 inl_spec | inline = Inline
419 | otherwise = NoInline
420 -- Currently we have no way to say Inlinable
422 cvtActivation Nothing | inline = AlwaysActive
423 | otherwise = NeverActive
424 cvtActivation (Just (False, phase)) = ActiveBefore phase
425 cvtActivation (Just (True , phase)) = ActiveAfter phase
427 ---------------------------------------------------
429 ---------------------------------------------------
431 cvtLocalDecs :: Message -> [TH.Dec] -> CvtM (HsLocalBinds RdrName)
434 = return EmptyLocalBinds
436 = do { ds' <- mapM cvtDec ds
437 ; let (binds, prob_sigs) = partitionWith is_bind ds'
438 ; let (sigs, bads) = partitionWith is_sig prob_sigs
439 ; unless (null bads) (failWith (mkBadDecMsg doc bads))
440 ; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) }
442 cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName)
443 cvtClause (Clause ps body wheres)
444 = do { ps' <- cvtPats ps
445 ; g' <- cvtGuard body
446 ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) wheres
447 ; returnL $ Hs.Match ps' Nothing (GRHSs g' ds') }
450 -------------------------------------------------------------------
452 -------------------------------------------------------------------
454 cvtl :: TH.Exp -> CvtM (LHsExpr RdrName)
455 cvtl e = wrapL (cvt e)
457 cvt (VarE s) = do { s' <- vName s; return $ HsVar s' }
458 cvt (ConE s) = do { s' <- cName s; return $ HsVar s' }
460 | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }
461 | otherwise = do { l' <- cvtLit l; return $ HsLit l' }
463 cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' }
464 cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e
465 ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) }
466 cvt (TupE [e]) = cvt e -- Singleton tuples treated like nothing (just parens)
467 cvt (TupE es) = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Boxed }
468 cvt (UnboxedTupE [e]) = cvt e -- Singleton tuples treated like nothing (just parens)
469 cvt (UnboxedTupE es) = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Unboxed }
470 cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
471 ; return $ HsIf (Just noSyntaxExpr) x' y' z' }
472 cvt (LetE ds e) = do { ds' <- cvtLocalDecs (ptext (sLit "a let expression")) ds
473 ; e' <- cvtl e; return $ HsLet ds' e' }
475 | null ms = failWith (ptext (sLit "Case expression with no alternatives"))
476 | otherwise = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
477 ; return $ HsCase e' (mkMatchGroup ms') }
478 cvt (DoE ss) = cvtHsDo DoExpr ss
479 cvt (CompE ss) = cvtHsDo ListComp ss
480 cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr dd' }
482 | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s); return (HsLit l') }
483 -- Note [Converting strings]
484 | otherwise = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' }
485 cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
486 ; e' <- returnL $ OpApp x' s' undefined y'
487 ; return $ HsPar e' }
488 cvt (InfixE Nothing s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
489 ; sec <- returnL $ SectionR s' y'
490 ; return $ HsPar sec }
491 cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
492 ; sec <- returnL $ SectionL x' s'
493 ; return $ HsPar sec }
494 cvt (InfixE Nothing s Nothing ) = cvt s -- Can I indicate this is an infix thing?
496 cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t
497 ; return $ ExprWithTySig e' t' }
498 cvt (RecConE c flds) = do { c' <- cNameL c
499 ; flds' <- mapM cvtFld flds
500 ; return $ RecordCon c' noPostTcExpr (HsRecFields flds' Nothing)}
501 cvt (RecUpdE e flds) = do { e' <- cvtl e
502 ; flds' <- mapM cvtFld flds
503 ; return $ RecordUpd e' (HsRecFields flds' Nothing) [] [] [] }
505 cvtFld :: (TH.Name, TH.Exp) -> CvtM (HsRecField RdrName (LHsExpr RdrName))
507 = do { v' <- vNameL v; e' <- cvtl e
508 ; return (HsRecField { hsRecFieldId = v', hsRecFieldArg = e', hsRecPun = False}) }
510 cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)
511 cvtDD (FromR x) = do { x' <- cvtl x; return $ From x' }
512 cvtDD (FromThenR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }
513 cvtDD (FromToR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
514 cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }
516 -------------------------------------
517 -- Do notation and statements
518 -------------------------------------
520 cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr RdrName)
521 cvtHsDo do_or_lc stmts
522 | null stmts = failWith (ptext (sLit "Empty stmt list in do-block"))
524 = do { stmts' <- cvtStmts stmts
525 ; body <- case last stmts' of
526 L _ (ExprStmt body _ _) -> return body
527 stmt' -> failWith (bad_last stmt')
528 ; return $ HsDo do_or_lc (init stmts') body void }
530 bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprStmtContext do_or_lc <> colon
531 , nest 2 $ Outputable.ppr stmt
532 , ptext (sLit "(It should be an expression.)") ]
534 cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName]
535 cvtStmts = mapM cvtStmt
537 cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName)
538 cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkExprStmt e' }
539 cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
540 cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (ptext (sLit "a let binding")) ds
541 ; returnL $ LetStmt ds' }
542 cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' }
544 cvt_one ds = do { ds' <- cvtStmts ds; return (ds', undefined) }
546 cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName)
547 cvtMatch (TH.Match p body decs)
548 = do { p' <- cvtPat p
549 ; g' <- cvtGuard body
550 ; decs' <- cvtLocalDecs (ptext (sLit "a where clause")) decs
551 ; returnL $ Hs.Match [p'] Nothing (GRHSs g' decs') }
553 cvtGuard :: TH.Body -> CvtM [LGRHS RdrName]
554 cvtGuard (GuardedB pairs) = mapM cvtpair pairs
555 cvtGuard (NormalB e) = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] }
557 cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName)
558 cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
559 ; g' <- returnL $ mkExprStmt ge'
560 ; returnL $ GRHS [g'] rhs' }
561 cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
562 ; returnL $ GRHS gs' rhs' }
564 cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
565 cvtOverLit (IntegerL i)
566 = do { force i; return $ mkHsIntegral i placeHolderType}
567 cvtOverLit (RationalL r)
568 = do { force r; return $ mkHsFractional r placeHolderType}
569 cvtOverLit (StringL s)
570 = do { let { s' = mkFastString s }
572 ; return $ mkHsIsString s' placeHolderType
574 cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
575 -- An Integer is like an (overloaded) '3' in a Haskell source program
576 -- Similarly 3.5 for fractionals
578 {- Note [Converting strings]
579 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
580 If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to
581 a string literal for "xy". Of course, we might hope to get
582 (LitE (StringL "xy")), but not always, and allCharLs fails quickly
583 if it isn't a literal string
586 allCharLs :: [TH.Exp] -> Maybe String
587 -- Note [Converting strings]
588 -- NB: only fire up this setup for a non-empty list, else
589 -- there's a danger of returning "" for [] :: [Int]!
592 LitE (CharL c) : ys -> go [c] ys
595 go cs [] = Just (reverse cs)
596 go cs (LitE (CharL c) : ys) = go (c:cs) ys
599 cvtLit :: Lit -> CvtM HsLit
600 cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim i }
601 cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim w }
602 cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim f }
603 cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim f }
604 cvtLit (CharL c) = do { force c; return $ HsChar c }
605 cvtLit (StringL s) = do { let { s' = mkFastString s }
607 ; return $ HsString s' }
608 cvtLit (StringPrimL s) = do { let { s' = mkFastString s }
610 ; return $ HsStringPrim s' }
611 cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
612 -- cvtLit should not be called on IntegerL, RationalL
613 -- That precondition is established right here in
614 -- Convert.lhs, hence panic
616 cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName]
617 cvtPats pats = mapM cvtPat pats
619 cvtPat :: TH.Pat -> CvtM (Hs.LPat RdrName)
620 cvtPat pat = wrapL (cvtp pat)
622 cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName)
624 | overloadedLit l = do { l' <- cvtOverLit l
625 ; return (mkNPat l' Nothing) }
626 -- Not right for negative patterns;
627 -- need to think about that!
628 | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat l' }
629 cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat s' }
630 cvtp (TupP [p]) = cvtp p
631 cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void }
632 cvtp (UnboxedTupP [p]) = cvtp p
633 cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed void }
634 cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps; return $ ConPatIn s' (PrefixCon ps') }
635 cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
636 ; return $ ConPatIn s' (InfixCon p1' p2') }
637 cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat p' }
638 cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat p' }
639 cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
640 cvtp TH.WildP = return $ WildPat void
641 cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
642 ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
643 cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void }
644 cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' }
645 cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p; return $ ViewPat e' p' void }
647 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
649 = do { s' <- vNameL s; p' <- cvtPat p
650 ; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) }
652 -----------------------------------------------------------
653 -- Types and type variables
655 cvtTvs :: [TH.TyVarBndr] -> CvtM [LHsTyVarBndr RdrName]
656 cvtTvs tvs = mapM cvt_tv tvs
658 cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
659 cvt_tv (TH.PlainTV nm)
660 = do { nm' <- tName nm
661 ; returnL $ UserTyVar nm' placeHolderKind
663 cvt_tv (TH.KindedTV nm ki)
664 = do { nm' <- tName nm
665 ; returnL $ KindedTyVar nm' (cvtKind ki)
668 cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
669 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
671 cvtPred :: TH.Pred -> CvtM (LHsPred RdrName)
672 cvtPred (TH.ClassP cla tys)
673 = do { cla' <- if isVarName cla then tName cla else tconName cla
674 ; tys' <- mapM cvtType tys
675 ; returnL $ HsClassP cla' tys'
677 cvtPred (TH.EqualP ty1 ty2)
678 = do { ty1' <- cvtType ty1
679 ; ty2' <- cvtType ty2
680 ; returnL $ HsEqualP ty1' ty2'
683 cvtPredTy :: TH.Type -> CvtM (LHsPred RdrName)
685 = do { (head, tys') <- split_ty_app ty
687 ConT tc -> do { tc' <- tconName tc; returnL $ HsClassP tc' tys' }
688 VarT tv -> do { tv' <- tName tv; returnL $ HsClassP tv' tys' }
689 _ -> failWith (ptext (sLit "Malformed predicate") <+>
690 text (TH.pprint ty)) }
692 cvtType :: TH.Type -> CvtM (LHsType RdrName)
694 = do { (head_ty, tys') <- split_ty_app ty
697 | length tys' == n -- Saturated
698 -> if n==1 then return (head tys') -- Singleton tuples treated
699 -- like nothing (ie just parens)
700 else returnL (HsTupleTy Boxed tys')
702 -> failWith (ptext (sLit "Illegal 1-tuple type constructor"))
704 -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys'
706 | length tys' == n -- Saturated
707 -> if n==1 then return (head tys') -- Singleton tuples treated
708 -- like nothing (ie just parens)
709 else returnL (HsTupleTy Unboxed tys')
711 -> failWith (ptext (sLit "Illegal 1-unboxed-tuple type constructor"))
713 -> mk_apps (HsTyVar (getRdrName (tupleTyCon Unboxed n))) tys'
715 | [x',y'] <- tys' -> returnL (HsFunTy x' y')
716 | otherwise -> mk_apps (HsTyVar (getRdrName funTyCon)) tys'
718 | [x'] <- tys' -> returnL (HsListTy x')
719 | otherwise -> mk_apps (HsTyVar (getRdrName listTyCon)) tys'
720 VarT nm -> do { nm' <- tName nm; mk_apps (HsTyVar nm') tys' }
721 ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' }
725 -> do { tvs' <- cvtTvs tvs
726 ; cxt' <- cvtContext cxt
728 ; returnL $ mkExplicitHsForAllTy tvs' cxt' ty'
732 -> do { ty' <- cvtType ty
733 ; mk_apps (HsKindSig ty' (cvtKind ki)) tys'
736 _ -> failWith (ptext (sLit "Malformed type") <+> text (show ty))
739 mk_apps head_ty [] = returnL head_ty
740 mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
741 ; mk_apps (HsAppTy head_ty' ty) tys }
743 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
744 split_ty_app ty = go ty []
746 go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
747 go f as = return (f,as)
749 cvtKind :: TH.Kind -> Type.Kind
750 cvtKind StarK = liftedTypeKind
751 cvtKind (ArrowK k1 k2) = mkArrowKind (cvtKind k1) (cvtKind k2)
753 -----------------------------------------------------------
756 -----------------------------------------------------------
757 -- some useful things
759 overloadedLit :: Lit -> Bool
760 -- True for literals that Haskell treats as overloaded
761 overloadedLit (IntegerL _) = True
762 overloadedLit (RationalL _) = True
763 overloadedLit _ = False
766 void = placeHolderType
768 --------------------------------------------------------------------
769 -- Turning Name back into RdrName
770 --------------------------------------------------------------------
773 vNameL, cNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
774 vName, cName, tName, tconName :: TH.Name -> CvtM RdrName
776 vNameL n = wrapL (vName n)
777 vName n = cvtName OccName.varName n
779 -- Constructor function names; this is Haskell source, hence srcDataName
780 cNameL n = wrapL (cName n)
781 cName n = cvtName OccName.dataName n
783 -- Type variable names
784 tName n = cvtName OccName.tvName n
786 -- Type Constructor names
787 tconNameL n = wrapL (tconName n)
788 tconName n = cvtName OccName.tcClsName n
790 cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
791 cvtName ctxt_ns (TH.Name occ flavour)
792 | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
793 | otherwise = force rdr_name >> return rdr_name
795 occ_str = TH.occString occ
796 rdr_name = thRdrName ctxt_ns occ_str flavour
798 okOcc :: OccName.NameSpace -> String -> Bool
801 | OccName.isVarNameSpace ns = startsVarId c || startsVarSym c
802 | otherwise = startsConId c || startsConSym c || str == "[]"
804 -- Determine the name space of a name in a type
806 isVarName :: TH.Name -> Bool
807 isVarName (TH.Name occ _)
808 = case TH.occString occ of
810 (c:_) -> startsVarId c || startsVarSym c
812 badOcc :: OccName.NameSpace -> String -> SDoc
814 = ptext (sLit "Illegal") <+> pprNameSpace ctxt_ns
815 <+> ptext (sLit "name:") <+> quotes (text occ)
817 thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
818 -- This turns a Name into a RdrName
819 -- The passed-in name space tells what the context is expecting;
820 -- use it unless the TH name knows what name-space it comes
821 -- from, in which case use the latter
823 -- ToDo: we may generate silly RdrNames, by passing a name space
824 -- that doesn't match the string, like VarName ":+",
825 -- which will give confusing error messages later
827 -- The strict applications ensure that any buried exceptions get forced
828 thRdrName _ occ (TH.NameG th_ns pkg mod) = thOrigRdrName occ th_ns pkg mod
829 thRdrName ctxt_ns occ (TH.NameL uniq) = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcSpan)
830 thRdrName ctxt_ns occ (TH.NameQ mod) = (mkRdrQual $! (mk_mod mod)) $! (mk_occ ctxt_ns occ)
831 thRdrName ctxt_ns occ (TH.NameU uniq) = mkRdrUnqual $! (mk_uniq_occ ctxt_ns occ uniq)
832 thRdrName ctxt_ns occ TH.NameS
833 | Just name <- isBuiltInOcc ctxt_ns occ = nameRdrName $! name
834 | otherwise = mkRdrUnqual $! (mk_occ ctxt_ns occ)
836 thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
837 thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)
839 thRdrNameGuesses :: TH.Name -> [RdrName]
840 thRdrNameGuesses (TH.Name occ flavour)
841 -- This special case for NameG ensures that we don't generate duplicates in the output list
842 | TH.NameG th_ns pkg mod <- flavour = [thOrigRdrName occ_str th_ns pkg mod]
843 | otherwise = [ thRdrName gns occ_str flavour
844 | gns <- guessed_nss]
846 -- guessed_ns are the name spaces guessed from looking at the TH name
847 guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName, OccName.dataName]
848 | otherwise = [OccName.varName, OccName.tvName]
849 occ_str = TH.occString occ
851 isBuiltInOcc :: OccName.NameSpace -> String -> Maybe Name.Name
852 -- Built in syntax isn't "in scope" so an Unqual RdrName won't do
853 -- We must generate an Exact name, just as the parser does
854 isBuiltInOcc ctxt_ns occ
856 ":" -> Just (Name.getName consDataCon)
857 "[]" -> Just (Name.getName nilDataCon)
858 "()" -> Just (tup_name 0)
859 '(' : ',' : rest -> go_tuple 2 rest
862 go_tuple n ")" = Just (tup_name n)
863 go_tuple n (',' : rest) = go_tuple (n+1) rest
864 go_tuple _ _ = Nothing
867 | OccName.isTcClsNameSpace ctxt_ns = Name.getName (tupleTyCon Boxed n)
868 | otherwise = Name.getName (tupleCon Boxed n)
870 mk_uniq_occ :: OccName.NameSpace -> String -> Int# -> OccName.OccName
871 mk_uniq_occ ns occ uniq
872 = OccName.mkOccName ns (occ ++ '[' : shows (mk_uniq uniq) "]")
873 -- See Note [Unique OccNames from Template Haskell]
875 -- The packing and unpacking is rather turgid :-(
876 mk_occ :: OccName.NameSpace -> String -> OccName.OccName
877 mk_occ ns occ = OccName.mkOccNameFS ns (mkFastString occ)
879 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
880 mk_ghc_ns TH.DataName = OccName.dataName
881 mk_ghc_ns TH.TcClsName = OccName.tcClsName
882 mk_ghc_ns TH.VarName = OccName.varName
884 mk_mod :: TH.ModName -> ModuleName
885 mk_mod mod = mkModuleName (TH.modString mod)
887 mk_pkg :: TH.PkgName -> PackageId
888 mk_pkg pkg = stringToPackageId (TH.pkgString pkg)
890 mk_uniq :: Int# -> Unique
891 mk_uniq u = mkUniqueGrimily (I# u)
894 Note [Unique OccNames from Template Haskell]
895 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
896 The idea here is to make a name that
897 a) the user could not possibly write (it has a "["
898 and letters or digits from the unique)
899 b) cannot clash with another NameU
900 Previously I generated an Exact RdrName with mkInternalName. This
901 works fine for local binders, but does not work at all for top-level
902 binders, which must have External Names, since they are rapidly baked
903 into data constructors and the like. Baling out and generating an
904 unqualified RdrName here is the simple solution
906 See also Note [Suppressing uniques in OccNames] in OccName, which
907 suppresses the unique when opt_SuppressUniques is on.