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 ; let Just (stmts'', last') = snocView stmts'
527 ; last'' <- case last' of
528 L loc (ExprStmt body _ _ _) -> return (L loc (mkLastStmt body))
529 _ -> failWith (bad_last last')
531 ; return $ HsDo do_or_lc (stmts'' ++ [last'']) void }
533 bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprAStmtContext do_or_lc <> colon
534 , nest 2 $ Outputable.ppr stmt
535 , ptext (sLit "(It should be an expression.)") ]
537 cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName]
538 cvtStmts = mapM cvtStmt
540 cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName)
541 cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkExprStmt e' }
542 cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
543 cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (ptext (sLit "a let binding")) ds
544 ; returnL $ LetStmt ds' }
545 cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noSyntaxExpr noSyntaxExpr noSyntaxExpr }
547 cvt_one ds = do { ds' <- cvtStmts ds; return (ds', undefined) }
549 cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName)
550 cvtMatch (TH.Match p body decs)
551 = do { p' <- cvtPat p
552 ; g' <- cvtGuard body
553 ; decs' <- cvtLocalDecs (ptext (sLit "a where clause")) decs
554 ; returnL $ Hs.Match [p'] Nothing (GRHSs g' decs') }
556 cvtGuard :: TH.Body -> CvtM [LGRHS RdrName]
557 cvtGuard (GuardedB pairs) = mapM cvtpair pairs
558 cvtGuard (NormalB e) = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] }
560 cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName)
561 cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
562 ; g' <- returnL $ mkExprStmt ge'
563 ; returnL $ GRHS [g'] rhs' }
564 cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
565 ; returnL $ GRHS gs' rhs' }
567 cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
568 cvtOverLit (IntegerL i)
569 = do { force i; return $ mkHsIntegral i placeHolderType}
570 cvtOverLit (RationalL r)
571 = do { force r; return $ mkHsFractional r placeHolderType}
572 cvtOverLit (StringL s)
573 = do { let { s' = mkFastString s }
575 ; return $ mkHsIsString s' placeHolderType
577 cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
578 -- An Integer is like an (overloaded) '3' in a Haskell source program
579 -- Similarly 3.5 for fractionals
581 {- Note [Converting strings]
582 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
583 If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to
584 a string literal for "xy". Of course, we might hope to get
585 (LitE (StringL "xy")), but not always, and allCharLs fails quickly
586 if it isn't a literal string
589 allCharLs :: [TH.Exp] -> Maybe String
590 -- Note [Converting strings]
591 -- NB: only fire up this setup for a non-empty list, else
592 -- there's a danger of returning "" for [] :: [Int]!
595 LitE (CharL c) : ys -> go [c] ys
598 go cs [] = Just (reverse cs)
599 go cs (LitE (CharL c) : ys) = go (c:cs) ys
602 cvtLit :: Lit -> CvtM HsLit
603 cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim i }
604 cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim w }
605 cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim f }
606 cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim f }
607 cvtLit (CharL c) = do { force c; return $ HsChar c }
608 cvtLit (StringL s) = do { let { s' = mkFastString s }
610 ; return $ HsString s' }
611 cvtLit (StringPrimL s) = do { let { s' = mkFastString s }
613 ; return $ HsStringPrim s' }
614 cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
615 -- cvtLit should not be called on IntegerL, RationalL
616 -- That precondition is established right here in
617 -- Convert.lhs, hence panic
619 cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName]
620 cvtPats pats = mapM cvtPat pats
622 cvtPat :: TH.Pat -> CvtM (Hs.LPat RdrName)
623 cvtPat pat = wrapL (cvtp pat)
625 cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName)
627 | overloadedLit l = do { l' <- cvtOverLit l
628 ; return (mkNPat l' Nothing) }
629 -- Not right for negative patterns;
630 -- need to think about that!
631 | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat l' }
632 cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat s' }
633 cvtp (TupP [p]) = cvtp p
634 cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void }
635 cvtp (UnboxedTupP [p]) = cvtp p
636 cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed void }
637 cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps; return $ ConPatIn s' (PrefixCon ps') }
638 cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
639 ; return $ ConPatIn s' (InfixCon p1' p2') }
640 cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat p' }
641 cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat p' }
642 cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
643 cvtp TH.WildP = return $ WildPat void
644 cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
645 ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
646 cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void }
647 cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' }
648 cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p; return $ ViewPat e' p' void }
650 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
652 = do { s' <- vNameL s; p' <- cvtPat p
653 ; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) }
655 -----------------------------------------------------------
656 -- Types and type variables
658 cvtTvs :: [TH.TyVarBndr] -> CvtM [LHsTyVarBndr RdrName]
659 cvtTvs tvs = mapM cvt_tv tvs
661 cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
662 cvt_tv (TH.PlainTV nm)
663 = do { nm' <- tName nm
664 ; returnL $ UserTyVar nm' placeHolderKind
666 cvt_tv (TH.KindedTV nm ki)
667 = do { nm' <- tName nm
668 ; returnL $ KindedTyVar nm' (cvtKind ki)
671 cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
672 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
674 cvtPred :: TH.Pred -> CvtM (LHsPred RdrName)
675 cvtPred (TH.ClassP cla tys)
676 = do { cla' <- if isVarName cla then tName cla else tconName cla
677 ; tys' <- mapM cvtType tys
678 ; returnL $ HsClassP cla' tys'
680 cvtPred (TH.EqualP ty1 ty2)
681 = do { ty1' <- cvtType ty1
682 ; ty2' <- cvtType ty2
683 ; returnL $ HsEqualP ty1' ty2'
686 cvtPredTy :: TH.Type -> CvtM (LHsPred RdrName)
688 = do { (head, tys') <- split_ty_app ty
690 ConT tc -> do { tc' <- tconName tc; returnL $ HsClassP tc' tys' }
691 VarT tv -> do { tv' <- tName tv; returnL $ HsClassP tv' tys' }
692 _ -> failWith (ptext (sLit "Malformed predicate") <+>
693 text (TH.pprint ty)) }
695 cvtType :: TH.Type -> CvtM (LHsType RdrName)
697 = do { (head_ty, tys') <- split_ty_app ty
700 | length tys' == n -- Saturated
701 -> if n==1 then return (head tys') -- Singleton tuples treated
702 -- like nothing (ie just parens)
703 else returnL (HsTupleTy Boxed tys')
705 -> failWith (ptext (sLit "Illegal 1-tuple type constructor"))
707 -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys'
709 | length tys' == n -- Saturated
710 -> if n==1 then return (head tys') -- Singleton tuples treated
711 -- like nothing (ie just parens)
712 else returnL (HsTupleTy Unboxed tys')
714 -> failWith (ptext (sLit "Illegal 1-unboxed-tuple type constructor"))
716 -> mk_apps (HsTyVar (getRdrName (tupleTyCon Unboxed n))) tys'
718 | [x',y'] <- tys' -> returnL (HsFunTy x' y')
719 | otherwise -> mk_apps (HsTyVar (getRdrName funTyCon)) tys'
721 | [x'] <- tys' -> returnL (HsListTy x')
722 | otherwise -> mk_apps (HsTyVar (getRdrName listTyCon)) tys'
723 VarT nm -> do { nm' <- tName nm; mk_apps (HsTyVar nm') tys' }
724 ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' }
728 -> do { tvs' <- cvtTvs tvs
729 ; cxt' <- cvtContext cxt
731 ; returnL $ mkExplicitHsForAllTy tvs' cxt' ty'
735 -> do { ty' <- cvtType ty
736 ; mk_apps (HsKindSig ty' (cvtKind ki)) tys'
739 _ -> failWith (ptext (sLit "Malformed type") <+> text (show ty))
742 mk_apps head_ty [] = returnL head_ty
743 mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
744 ; mk_apps (HsAppTy head_ty' ty) tys }
746 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
747 split_ty_app ty = go ty []
749 go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
750 go f as = return (f,as)
752 cvtKind :: TH.Kind -> Type.Kind
753 cvtKind StarK = liftedTypeKind
754 cvtKind (ArrowK k1 k2) = mkArrowKind (cvtKind k1) (cvtKind k2)
756 -----------------------------------------------------------
759 -----------------------------------------------------------
760 -- some useful things
762 overloadedLit :: Lit -> Bool
763 -- True for literals that Haskell treats as overloaded
764 overloadedLit (IntegerL _) = True
765 overloadedLit (RationalL _) = True
766 overloadedLit _ = False
769 void = placeHolderType
771 --------------------------------------------------------------------
772 -- Turning Name back into RdrName
773 --------------------------------------------------------------------
776 vNameL, cNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
777 vName, cName, tName, tconName :: TH.Name -> CvtM RdrName
779 vNameL n = wrapL (vName n)
780 vName n = cvtName OccName.varName n
782 -- Constructor function names; this is Haskell source, hence srcDataName
783 cNameL n = wrapL (cName n)
784 cName n = cvtName OccName.dataName n
786 -- Type variable names
787 tName n = cvtName OccName.tvName n
789 -- Type Constructor names
790 tconNameL n = wrapL (tconName n)
791 tconName n = cvtName OccName.tcClsName n
793 cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
794 cvtName ctxt_ns (TH.Name occ flavour)
795 | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
796 | otherwise = force rdr_name >> return rdr_name
798 occ_str = TH.occString occ
799 rdr_name = thRdrName ctxt_ns occ_str flavour
801 okOcc :: OccName.NameSpace -> String -> Bool
804 | OccName.isVarNameSpace ns = startsVarId c || startsVarSym c
805 | otherwise = startsConId c || startsConSym c || str == "[]"
807 -- Determine the name space of a name in a type
809 isVarName :: TH.Name -> Bool
810 isVarName (TH.Name occ _)
811 = case TH.occString occ of
813 (c:_) -> startsVarId c || startsVarSym c
815 badOcc :: OccName.NameSpace -> String -> SDoc
817 = ptext (sLit "Illegal") <+> pprNameSpace ctxt_ns
818 <+> ptext (sLit "name:") <+> quotes (text occ)
820 thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
821 -- This turns a Name into a RdrName
822 -- The passed-in name space tells what the context is expecting;
823 -- use it unless the TH name knows what name-space it comes
824 -- from, in which case use the latter
826 -- ToDo: we may generate silly RdrNames, by passing a name space
827 -- that doesn't match the string, like VarName ":+",
828 -- which will give confusing error messages later
830 -- The strict applications ensure that any buried exceptions get forced
831 thRdrName _ occ (TH.NameG th_ns pkg mod) = thOrigRdrName occ th_ns pkg mod
832 thRdrName ctxt_ns occ (TH.NameL uniq) = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcSpan)
833 thRdrName ctxt_ns occ (TH.NameQ mod) = (mkRdrQual $! (mk_mod mod)) $! (mk_occ ctxt_ns occ)
834 thRdrName ctxt_ns occ (TH.NameU uniq) = mkRdrUnqual $! (mk_uniq_occ ctxt_ns occ uniq)
835 thRdrName ctxt_ns occ TH.NameS
836 | Just name <- isBuiltInOcc ctxt_ns occ = nameRdrName $! name
837 | otherwise = mkRdrUnqual $! (mk_occ ctxt_ns occ)
839 thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
840 thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)
842 thRdrNameGuesses :: TH.Name -> [RdrName]
843 thRdrNameGuesses (TH.Name occ flavour)
844 -- This special case for NameG ensures that we don't generate duplicates in the output list
845 | TH.NameG th_ns pkg mod <- flavour = [thOrigRdrName occ_str th_ns pkg mod]
846 | otherwise = [ thRdrName gns occ_str flavour
847 | gns <- guessed_nss]
849 -- guessed_ns are the name spaces guessed from looking at the TH name
850 guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName, OccName.dataName]
851 | otherwise = [OccName.varName, OccName.tvName]
852 occ_str = TH.occString occ
854 isBuiltInOcc :: OccName.NameSpace -> String -> Maybe Name.Name
855 -- Built in syntax isn't "in scope" so an Unqual RdrName won't do
856 -- We must generate an Exact name, just as the parser does
857 isBuiltInOcc ctxt_ns occ
859 ":" -> Just (Name.getName consDataCon)
860 "[]" -> Just (Name.getName nilDataCon)
861 "()" -> Just (tup_name 0)
862 '(' : ',' : rest -> go_tuple 2 rest
865 go_tuple n ")" = Just (tup_name n)
866 go_tuple n (',' : rest) = go_tuple (n+1) rest
867 go_tuple _ _ = Nothing
870 | OccName.isTcClsNameSpace ctxt_ns = Name.getName (tupleTyCon Boxed n)
871 | otherwise = Name.getName (tupleCon Boxed n)
873 mk_uniq_occ :: OccName.NameSpace -> String -> Int# -> OccName.OccName
874 mk_uniq_occ ns occ uniq
875 = OccName.mkOccName ns (occ ++ '[' : shows (mk_uniq uniq) "]")
876 -- See Note [Unique OccNames from Template Haskell]
878 -- The packing and unpacking is rather turgid :-(
879 mk_occ :: OccName.NameSpace -> String -> OccName.OccName
880 mk_occ ns occ = OccName.mkOccNameFS ns (mkFastString occ)
882 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
883 mk_ghc_ns TH.DataName = OccName.dataName
884 mk_ghc_ns TH.TcClsName = OccName.tcClsName
885 mk_ghc_ns TH.VarName = OccName.varName
887 mk_mod :: TH.ModName -> ModuleName
888 mk_mod mod = mkModuleName (TH.modString mod)
890 mk_pkg :: TH.PkgName -> PackageId
891 mk_pkg pkg = stringToPackageId (TH.pkgString pkg)
893 mk_uniq :: Int# -> Unique
894 mk_uniq u = mkUniqueGrimily (I# u)
897 Note [Unique OccNames from Template Haskell]
898 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
899 The idea here is to make a name that
900 a) the user could not possibly write (it has a "["
901 and letters or digits from the unique)
902 b) cannot clash with another NameU
903 Previously I generated an Exact RdrName with mkInternalName. This
904 works fine for local binders, but does not work at all for top-level
905 binders, which must have External Names, since they are rapidly baked
906 into data constructors and the like. Baling out and generating an
907 unqualified RdrName here is the simple solution
909 See also Note [Suppressing uniques in OccNames] in OccName, which
910 suppresses the unique when opt_SuppressUniques is on.