5f67515c71dd4998540b469e0c145b2bee19fa35
[ghc.git] / compiler / hsSyn / Convert.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
6 This module converts Template Haskell syntax into HsSyn
7 -}
8
9 {-# LANGUAGE ScopedTypeVariables #-}
10
11 module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
12 convertToHsType,
13 thRdrNameGuesses ) where
14
15 import HsSyn as Hs
16 import qualified Class
17 import RdrName
18 import qualified Name
19 import Module
20 import RdrHsSyn
21 import qualified OccName
22 import OccName
23 import SrcLoc
24 import Type
25 import qualified Coercion ( Role(..) )
26 import TysWiredIn
27 import TysPrim (eqPrimTyCon)
28 import BasicTypes as Hs
29 import ForeignCall
30 import Unique
31 import ErrUtils
32 import Bag
33 import Lexeme
34 import Util
35 import FastString
36 import Outputable
37 import MonadUtils ( foldrM )
38
39 import qualified Data.ByteString as BS
40 import Control.Monad( unless, liftM, ap, (<=<) )
41
42 import Data.Maybe( catMaybes, fromMaybe, isNothing )
43 import Language.Haskell.TH as TH hiding (sigP)
44 import Language.Haskell.TH.Syntax as TH
45
46 -------------------------------------------------------------------
47 -- The external interface
48
49 convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl RdrName]
50 convertToHsDecls loc ds = initCvt loc (fmap catMaybes (mapM cvt_dec ds))
51 where
52 cvt_dec d = wrapMsg "declaration" d (cvtDec d)
53
54 convertToHsExpr :: SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr RdrName)
55 convertToHsExpr loc e
56 = initCvt loc $ wrapMsg "expression" e $ cvtl e
57
58 convertToPat :: SrcSpan -> TH.Pat -> Either MsgDoc (LPat RdrName)
59 convertToPat loc p
60 = initCvt loc $ wrapMsg "pattern" p $ cvtPat p
61
62 convertToHsType :: SrcSpan -> TH.Type -> Either MsgDoc (LHsType RdrName)
63 convertToHsType loc t
64 = initCvt loc $ wrapMsg "type" t $ cvtType t
65
66 -------------------------------------------------------------------
67 newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) }
68 -- Push down the source location;
69 -- Can fail, with a single error message
70
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
75
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
79
80 instance Functor CvtM where
81 fmap = liftM
82
83 instance Applicative CvtM where
84 pure x = CvtM $ \loc -> Right (loc,x)
85 (<*>) = ap
86
87 instance Monad CvtM where
88 (CvtM m) >>= k = CvtM $ \loc -> case m loc of
89 Left err -> Left err
90 Right (loc',v) -> unCvtM (k v) loc'
91
92 initCvt :: SrcSpan -> CvtM a -> Either MsgDoc a
93 initCvt loc (CvtM m) = fmap snd (m loc)
94
95 force :: a -> CvtM ()
96 force a = a `seq` return ()
97
98 failWith :: MsgDoc -> CvtM a
99 failWith m = CvtM (\_ -> Left m)
100
101 getL :: CvtM SrcSpan
102 getL = CvtM (\loc -> Right (loc,loc))
103
104 setL :: SrcSpan -> CvtM ()
105 setL loc = CvtM (\_ -> Right (loc, ()))
106
107 returnL :: a -> CvtM (Located a)
108 returnL x = CvtM (\loc -> Right (loc, L loc x))
109
110 returnJustL :: a -> CvtM (Maybe (Located a))
111 returnJustL = fmap Just . returnL
112
113 wrapParL :: (Located a -> a) -> a -> CvtM a
114 wrapParL add_par x = CvtM (\loc -> Right (loc, add_par (L loc x)))
115
116 wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b
117 -- E.g wrapMsg "declaration" dec thing
118 wrapMsg what item (CvtM m)
119 = CvtM (\loc -> case m loc of
120 Left err -> Left (err $$ getPprStyle msg)
121 Right v -> Right v)
122 where
123 -- Show the item in pretty syntax normally,
124 -- but with all its constructors if you say -dppr-debug
125 msg sty = hang (text "When splicing a TH" <+> text what <> colon)
126 2 (if debugStyle sty
127 then text (show item)
128 else text (pprint item))
129
130 wrapL :: CvtM a -> CvtM (Located a)
131 wrapL (CvtM m) = CvtM (\loc -> case m loc of
132 Left err -> Left err
133 Right (loc',v) -> Right (loc',L loc v))
134
135 -------------------------------------------------------------------
136 cvtDecs :: [TH.Dec] -> CvtM [LHsDecl RdrName]
137 cvtDecs = fmap catMaybes . mapM cvtDec
138
139 cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl RdrName))
140 cvtDec (TH.ValD pat body ds)
141 | TH.VarP s <- pat
142 = do { s' <- vNameL s
143 ; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds)
144 ; returnJustL $ Hs.ValD $ mkFunBind s' [cl'] }
145
146 | otherwise
147 = do { pat' <- cvtPat pat
148 ; body' <- cvtGuard body
149 ; ds' <- cvtLocalDecs (text "a where clause") ds
150 ; returnJustL $ Hs.ValD $
151 PatBind { pat_lhs = pat', pat_rhs = GRHSs body' (noLoc ds')
152 , pat_rhs_ty = placeHolderType, bind_fvs = placeHolderNames
153 , pat_ticks = ([],[]) } }
154
155 cvtDec (TH.FunD nm cls)
156 | null cls
157 = failWith (text "Function binding for"
158 <+> quotes (text (TH.pprint nm))
159 <+> text "has no equations")
160 | otherwise
161 = do { nm' <- vNameL nm
162 ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls
163 ; returnJustL $ Hs.ValD $ mkFunBind nm' cls' }
164
165 cvtDec (TH.SigD nm typ)
166 = do { nm' <- vNameL nm
167 ; ty' <- cvtType typ
168 ; returnJustL $ Hs.SigD (TypeSig [nm'] (mkLHsSigWcType ty')) }
169
170 cvtDec (TH.InfixD fx nm)
171 -- Fixity signatures are allowed for variables, constructors, and types
172 -- the renamer automatically looks for types during renaming, even when
173 -- the RdrName says it's a variable or a constructor. So, just assume
174 -- it's a variable or constructor and proceed.
175 = do { nm' <- vcNameL nm
176 ; returnJustL (Hs.SigD (FixSig (FixitySig [nm'] (cvtFixity fx)))) }
177
178 cvtDec (PragmaD prag)
179 = cvtPragmaD prag
180
181 cvtDec (TySynD tc tvs rhs)
182 = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
183 ; rhs' <- cvtType rhs
184 ; returnJustL $ TyClD $
185 SynDecl { tcdLName = tc', tcdTyVars = tvs'
186 , tcdFixity = Prefix
187 , tcdFVs = placeHolderNames
188 , tcdRhs = rhs' } }
189
190 cvtDec (DataD ctxt tc tvs ksig constrs derivs)
191 = do { let isGadtCon (GadtC _ _ _) = True
192 isGadtCon (RecGadtC _ _ _) = True
193 isGadtCon (ForallC _ _ c) = isGadtCon c
194 isGadtCon _ = False
195 isGadtDecl = all isGadtCon constrs
196 isH98Decl = all (not . isGadtCon) constrs
197 ; unless (isGadtDecl || isH98Decl)
198 (failWith (text "Cannot mix GADT constructors with Haskell 98"
199 <+> text "constructors"))
200 ; unless (isNothing ksig || isGadtDecl)
201 (failWith (text "Kind signatures are only allowed on GADTs"))
202 ; (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
203 ; ksig' <- cvtKind `traverse` ksig
204 ; cons' <- mapM cvtConstr constrs
205 ; derivs' <- cvtDerivs derivs
206 ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
207 , dd_ctxt = ctxt'
208 , dd_kindSig = ksig'
209 , dd_cons = cons', dd_derivs = derivs' }
210 ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
211 , tcdFixity = Prefix
212 , tcdDataDefn = defn
213 , tcdDataCusk = PlaceHolder
214 , tcdFVs = placeHolderNames }) }
215
216 cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)
217 = do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
218 ; ksig' <- cvtKind `traverse` ksig
219 ; con' <- cvtConstr constr
220 ; derivs' <- cvtDerivs derivs
221 ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
222 , dd_ctxt = ctxt'
223 , dd_kindSig = ksig'
224 , dd_cons = [con']
225 , dd_derivs = derivs' }
226 ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
227 , tcdFixity = Prefix
228 , tcdDataDefn = defn
229 , tcdDataCusk = PlaceHolder
230 , tcdFVs = placeHolderNames }) }
231
232 cvtDec (ClassD ctxt cl tvs fds decs)
233 = do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
234 ; fds' <- mapM cvt_fundep fds
235 ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs (text "a class declaration") decs
236 ; unless (null adts')
237 (failWith $ (text "Default data instance declarations"
238 <+> text "are not allowed:")
239 $$ (Outputable.ppr adts'))
240 ; at_defs <- mapM cvt_at_def ats'
241 ; returnJustL $ TyClD $
242 ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
243 , tcdFixity = Prefix
244 , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'
245 , tcdMeths = binds'
246 , tcdATs = fams', tcdATDefs = at_defs, tcdDocs = []
247 , tcdFVs = placeHolderNames }
248 -- no docs in TH ^^
249 }
250 where
251 cvt_at_def :: LTyFamInstDecl RdrName -> CvtM (LTyFamDefltEqn RdrName)
252 -- Very similar to what happens in RdrHsSyn.mkClassDecl
253 cvt_at_def decl = case RdrHsSyn.mkATDefault decl of
254 Right def -> return def
255 Left (_, msg) -> failWith msg
256
257 cvtDec (InstanceD o ctxt ty decs)
258 = do { let doc = text "an instance declaration"
259 ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs
260 ; unless (null fams') (failWith (mkBadDecMsg doc fams'))
261 ; ctxt' <- cvtContext ctxt
262 ; L loc ty' <- cvtType ty
263 ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ L loc ty'
264 ; returnJustL $ InstD $ ClsInstD $
265 ClsInstDecl { cid_poly_ty = mkLHsSigType inst_ty'
266 , cid_binds = binds'
267 , cid_sigs = Hs.mkClassOpSigs sigs'
268 , cid_tyfam_insts = ats', cid_datafam_insts = adts'
269 , cid_overlap_mode = fmap (L loc . overlap) o } }
270 where
271 overlap pragma =
272 case pragma of
273 TH.Overlaps -> Hs.Overlaps (SourceText "OVERLAPS")
274 TH.Overlappable -> Hs.Overlappable (SourceText "OVERLAPPABLE")
275 TH.Overlapping -> Hs.Overlapping (SourceText "OVERLAPPING")
276 TH.Incoherent -> Hs.Incoherent (SourceText "INCOHERENT")
277
278
279
280
281 cvtDec (ForeignD ford)
282 = do { ford' <- cvtForD ford
283 ; returnJustL $ ForD ford' }
284
285 cvtDec (DataFamilyD tc tvs kind)
286 = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
287 ; result <- cvtMaybeKindToFamilyResultSig kind
288 ; returnJustL $ TyClD $ FamDecl $
289 FamilyDecl DataFamily tc' tvs' Prefix result Nothing }
290
291 cvtDec (DataInstD ctxt tc tys ksig constrs derivs)
292 = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
293 ; ksig' <- cvtKind `traverse` ksig
294 ; cons' <- mapM cvtConstr constrs
295 ; derivs' <- cvtDerivs derivs
296 ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
297 , dd_ctxt = ctxt'
298 , dd_kindSig = ksig'
299 , dd_cons = cons', dd_derivs = derivs' }
300
301 ; returnJustL $ InstD $ DataFamInstD
302 { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
303 , dfid_defn = defn
304 , dfid_fixity = Prefix
305 , dfid_fvs = placeHolderNames } }}
306
307 cvtDec (NewtypeInstD ctxt tc tys ksig constr derivs)
308 = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
309 ; ksig' <- cvtKind `traverse` ksig
310 ; con' <- cvtConstr constr
311 ; derivs' <- cvtDerivs derivs
312 ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
313 , dd_ctxt = ctxt'
314 , dd_kindSig = ksig'
315 , dd_cons = [con'], dd_derivs = derivs' }
316 ; returnJustL $ InstD $ DataFamInstD
317 { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
318 , dfid_defn = defn
319 , dfid_fixity = Prefix
320 , dfid_fvs = placeHolderNames } }}
321
322 cvtDec (TySynInstD tc eqn)
323 = do { tc' <- tconNameL tc
324 ; eqn' <- cvtTySynEqn tc' eqn
325 ; returnJustL $ InstD $ TyFamInstD
326 { tfid_inst = TyFamInstDecl { tfid_eqn = eqn'
327 , tfid_fvs = placeHolderNames } } }
328
329 cvtDec (OpenTypeFamilyD head)
330 = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
331 ; returnJustL $ TyClD $ FamDecl $
332 FamilyDecl OpenTypeFamily tc' tyvars' Prefix result' injectivity' }
333
334 cvtDec (ClosedTypeFamilyD head eqns)
335 = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
336 ; eqns' <- mapM (cvtTySynEqn tc') eqns
337 ; returnJustL $ TyClD $ FamDecl $
338 FamilyDecl (ClosedTypeFamily (Just eqns')) tc' tyvars' Prefix result'
339 injectivity' }
340
341 cvtDec (TH.RoleAnnotD tc roles)
342 = do { tc' <- tconNameL tc
343 ; let roles' = map (noLoc . cvtRole) roles
344 ; returnJustL $ Hs.RoleAnnotD (RoleAnnotDecl tc' roles') }
345
346 cvtDec (TH.StandaloneDerivD ds cxt ty)
347 = do { cxt' <- cvtContext cxt
348 ; L loc ty' <- cvtType ty
349 ; let inst_ty' = mkHsQualTy cxt loc cxt' $ L loc ty'
350 ; returnJustL $ DerivD $
351 DerivDecl { deriv_strategy = fmap (L loc . cvtDerivStrategy) ds
352 , deriv_type = mkLHsSigType inst_ty'
353 , deriv_overlap_mode = Nothing } }
354
355 cvtDec (TH.DefaultSigD nm typ)
356 = do { nm' <- vNameL nm
357 ; ty' <- cvtType typ
358 ; returnJustL $ Hs.SigD $ ClassOpSig True [nm'] (mkLHsSigType ty') }
359
360 cvtDec (TH.PatSynD nm args dir pat)
361 = do { nm' <- cNameL nm
362 ; args' <- cvtArgs args
363 ; dir' <- cvtDir nm' dir
364 ; pat' <- cvtPat pat
365 ; returnJustL $ Hs.ValD $ PatSynBind $
366 PSB nm' placeHolderType args' pat' dir' }
367 where
368 cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixPatSyn <$> mapM vNameL args
369 cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixPatSyn <$> vNameL a1 <*> vNameL a2
370 cvtArgs (TH.RecordPatSyn sels)
371 = do { sels' <- mapM vNameL sels
372 ; vars' <- mapM (vNameL . mkNameS . nameBase) sels
373 ; return $ Hs.RecordPatSyn $ zipWith RecordPatSynField sels' vars' }
374
375 cvtDir _ Unidir = return Unidirectional
376 cvtDir _ ImplBidir = return ImplicitBidirectional
377 cvtDir n (ExplBidir cls) =
378 do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls
379 ; return $ ExplicitBidirectional $ mkMatchGroup FromSource ms }
380
381 cvtDec (TH.PatSynSigD nm ty)
382 = do { nm' <- cNameL nm
383 ; ty' <- cvtPatSynSigTy ty
384 ; returnJustL $ Hs.SigD $ PatSynSig [nm'] (mkLHsSigType ty') }
385
386 ----------------
387 cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName)
388 cvtTySynEqn tc (TySynEqn lhs rhs)
389 = do { lhs' <- mapM (wrap_apps <=< cvtType) lhs
390 ; rhs' <- cvtType rhs
391 ; returnL $ TyFamEqn { tfe_tycon = tc
392 , tfe_pats = mkHsImplicitBndrs lhs'
393 , tfe_fixity = Prefix
394 , tfe_rhs = rhs' } }
395
396 ----------------
397 cvt_ci_decs :: MsgDoc -> [TH.Dec]
398 -> CvtM (LHsBinds RdrName,
399 [LSig RdrName],
400 [LFamilyDecl RdrName],
401 [LTyFamInstDecl RdrName],
402 [LDataFamInstDecl RdrName])
403 -- Convert the declarations inside a class or instance decl
404 -- ie signatures, bindings, and associated types
405 cvt_ci_decs doc decs
406 = do { decs' <- cvtDecs decs
407 ; let (ats', bind_sig_decs') = partitionWith is_tyfam_inst decs'
408 ; let (adts', no_ats') = partitionWith is_datafam_inst bind_sig_decs'
409 ; let (sigs', prob_binds') = partitionWith is_sig no_ats'
410 ; let (binds', prob_fams') = partitionWith is_bind prob_binds'
411 ; let (fams', bads) = partitionWith is_fam_decl prob_fams'
412 ; unless (null bads) (failWith (mkBadDecMsg doc bads))
413 --We use FromSource as the origin of the bind
414 -- because the TH declaration is user-written
415 ; return (listToBag binds', sigs', fams', ats', adts') }
416
417 ----------------
418 cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
419 -> CvtM ( LHsContext RdrName
420 , Located RdrName
421 , LHsQTyVars RdrName)
422 cvt_tycl_hdr cxt tc tvs
423 = do { cxt' <- cvtContext cxt
424 ; tc' <- tconNameL tc
425 ; tvs' <- cvtTvs tvs
426 ; return (cxt', tc', tvs')
427 }
428
429 cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
430 -> CvtM ( LHsContext RdrName
431 , Located RdrName
432 , HsImplicitBndrs RdrName [LHsType RdrName])
433 cvt_tyinst_hdr cxt tc tys
434 = do { cxt' <- cvtContext cxt
435 ; tc' <- tconNameL tc
436 ; tys' <- mapM (wrap_apps <=< cvtType) tys
437 ; return (cxt', tc', mkHsImplicitBndrs tys') }
438
439 ----------------
440 cvt_tyfam_head :: TypeFamilyHead
441 -> CvtM ( Located RdrName
442 , LHsQTyVars RdrName
443 , Hs.LFamilyResultSig RdrName
444 , Maybe (Hs.LInjectivityAnn RdrName))
445
446 cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity)
447 = do {(_, tc', tyvars') <- cvt_tycl_hdr [] tc tyvars
448 ; result' <- cvtFamilyResultSig result
449 ; injectivity' <- traverse cvtInjectivityAnnotation injectivity
450 ; return (tc', tyvars', result', injectivity') }
451
452 -------------------------------------------------------------------
453 -- Partitioning declarations
454 -------------------------------------------------------------------
455
456 is_fam_decl :: LHsDecl RdrName -> Either (LFamilyDecl RdrName) (LHsDecl RdrName)
457 is_fam_decl (L loc (TyClD (FamDecl { tcdFam = d }))) = Left (L loc d)
458 is_fam_decl decl = Right decl
459
460 is_tyfam_inst :: LHsDecl RdrName -> Either (LTyFamInstDecl RdrName) (LHsDecl RdrName)
461 is_tyfam_inst (L loc (Hs.InstD (TyFamInstD { tfid_inst = d }))) = Left (L loc d)
462 is_tyfam_inst decl = Right decl
463
464 is_datafam_inst :: LHsDecl RdrName -> Either (LDataFamInstDecl RdrName) (LHsDecl RdrName)
465 is_datafam_inst (L loc (Hs.InstD (DataFamInstD { dfid_inst = d }))) = Left (L loc d)
466 is_datafam_inst decl = Right decl
467
468 is_sig :: LHsDecl RdrName -> Either (LSig RdrName) (LHsDecl RdrName)
469 is_sig (L loc (Hs.SigD sig)) = Left (L loc sig)
470 is_sig decl = Right decl
471
472 is_bind :: LHsDecl RdrName -> Either (LHsBind RdrName) (LHsDecl RdrName)
473 is_bind (L loc (Hs.ValD bind)) = Left (L loc bind)
474 is_bind decl = Right decl
475
476 mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc
477 mkBadDecMsg doc bads
478 = sep [ text "Illegal declaration(s) in" <+> doc <> colon
479 , nest 2 (vcat (map Outputable.ppr bads)) ]
480
481 ---------------------------------------------------
482 -- Data types
483 ---------------------------------------------------
484
485 cvtConstr :: TH.Con -> CvtM (LConDecl RdrName)
486
487 cvtConstr (NormalC c strtys)
488 = do { c' <- cNameL c
489 ; cxt' <- returnL []
490 ; tys' <- mapM cvt_arg strtys
491 ; returnL $ mkConDeclH98 c' Nothing cxt' (PrefixCon tys') }
492
493 cvtConstr (RecC c varstrtys)
494 = do { c' <- cNameL c
495 ; cxt' <- returnL []
496 ; args' <- mapM cvt_id_arg varstrtys
497 ; returnL $ mkConDeclH98 c' Nothing cxt'
498 (RecCon (noLoc args')) }
499
500 cvtConstr (InfixC st1 c st2)
501 = do { c' <- cNameL c
502 ; cxt' <- returnL []
503 ; st1' <- cvt_arg st1
504 ; st2' <- cvt_arg st2
505 ; returnL $ mkConDeclH98 c' Nothing cxt' (InfixCon st1' st2') }
506
507 cvtConstr (ForallC tvs ctxt con)
508 = do { tvs' <- cvtTvs tvs
509 ; L loc ctxt' <- cvtContext ctxt
510 ; L _ con' <- cvtConstr con
511 ; returnL $ case con' of
512 ConDeclGADT { con_type = conT } ->
513 let hs_ty = mkHsForAllTy tvs noSrcSpan tvs' rho_ty
514 rho_ty = mkHsQualTy ctxt noSrcSpan (L loc ctxt')
515 (hsib_body conT)
516 in con' { con_type = mkHsImplicitBndrs hs_ty }
517 ConDeclH98 {} ->
518 let qvars = case (tvs, con_qvars con') of
519 ([], Nothing) -> Nothing
520 (_ , m_qvs ) -> Just $
521 mkHsQTvs (hsQTvExplicit tvs' ++
522 maybe [] hsQTvExplicit m_qvs)
523 in con' { con_qvars = qvars
524 , con_cxt = Just $
525 L loc (ctxt' ++
526 unLoc (fromMaybe (noLoc [])
527 (con_cxt con'))) } }
528
529 cvtConstr (GadtC c strtys ty)
530 = do { c' <- mapM cNameL c
531 ; args <- mapM cvt_arg strtys
532 ; L _ ty' <- cvtType ty
533 ; c_ty <- mk_arr_apps args ty'
534 ; returnL $ mkGadtDecl c' (mkLHsSigType c_ty)}
535
536 cvtConstr (RecGadtC c varstrtys ty)
537 = do { c' <- mapM cNameL c
538 ; ty' <- cvtType ty
539 ; rec_flds <- mapM cvt_id_arg varstrtys
540 ; let rec_ty = noLoc (HsFunTy (noLoc $ HsRecTy rec_flds) ty')
541 ; returnL $ mkGadtDecl c' (mkLHsSigType rec_ty) }
542
543 cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness
544 cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack
545 cvtSrcUnpackedness SourceNoUnpack = SrcNoUnpack
546 cvtSrcUnpackedness SourceUnpack = SrcUnpack
547
548 cvtSrcStrictness :: TH.SourceStrictness -> SrcStrictness
549 cvtSrcStrictness NoSourceStrictness = NoSrcStrict
550 cvtSrcStrictness SourceLazy = SrcLazy
551 cvtSrcStrictness SourceStrict = SrcStrict
552
553 cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType RdrName)
554 cvt_arg (Bang su ss, ty)
555 = do { ty'' <- cvtType ty
556 ; ty' <- wrap_apps ty''
557 ; let su' = cvtSrcUnpackedness su
558 ; let ss' = cvtSrcStrictness ss
559 ; returnL $ HsBangTy (HsSrcBang NoSourceText su' ss') ty' }
560
561 cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField RdrName)
562 cvt_id_arg (i, str, ty)
563 = do { L li i' <- vNameL i
564 ; ty' <- cvt_arg (str,ty)
565 ; return $ noLoc (ConDeclField
566 { cd_fld_names
567 = [L li $ FieldOcc (L li i') PlaceHolder]
568 , cd_fld_type = ty'
569 , cd_fld_doc = Nothing}) }
570
571 cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving RdrName)
572 cvtDerivs cs = do { cs' <- mapM cvtDerivClause cs
573 ; returnL cs' }
574
575 cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep (Located RdrName)))
576 cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs
577 ; ys' <- mapM tNameL ys
578 ; returnL (xs', ys') }
579
580
581 ------------------------------------------
582 -- Foreign declarations
583 ------------------------------------------
584
585 cvtForD :: Foreign -> CvtM (ForeignDecl RdrName)
586 cvtForD (ImportF callconv safety from nm ty)
587 -- the prim and javascript calling conventions do not support headers
588 -- and are inserted verbatim, analogous to mkImport in RdrHsSyn
589 | callconv == TH.Prim || callconv == TH.JavaScript
590 = mk_imp (CImport (noLoc (cvt_conv callconv)) (noLoc safety') Nothing
591 (CFunction (StaticTarget (SourceText from)
592 (mkFastString from) Nothing
593 True))
594 (noLoc $ quotedSourceText from))
595 | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety')
596 (mkFastString (TH.nameBase nm))
597 from (noLoc $ quotedSourceText from)
598 = mk_imp impspec
599 | otherwise
600 = failWith $ text (show from) <+> text "is not a valid ccall impent"
601 where
602 mk_imp impspec
603 = do { nm' <- vNameL nm
604 ; ty' <- cvtType ty
605 ; return (ForeignImport { fd_name = nm'
606 , fd_sig_ty = mkLHsSigType ty'
607 , fd_co = noForeignImportCoercionYet
608 , fd_fi = impspec })
609 }
610 safety' = case safety of
611 Unsafe -> PlayRisky
612 Safe -> PlaySafe
613 Interruptible -> PlayInterruptible
614
615 cvtForD (ExportF callconv as nm ty)
616 = do { nm' <- vNameL nm
617 ; ty' <- cvtType ty
618 ; let e = CExport (noLoc (CExportStatic (SourceText as)
619 (mkFastString as)
620 (cvt_conv callconv)))
621 (noLoc (SourceText as))
622 ; return $ ForeignExport { fd_name = nm'
623 , fd_sig_ty = mkLHsSigType ty'
624 , fd_co = noForeignExportCoercionYet
625 , fd_fe = e } }
626
627 cvt_conv :: TH.Callconv -> CCallConv
628 cvt_conv TH.CCall = CCallConv
629 cvt_conv TH.StdCall = StdCallConv
630 cvt_conv TH.CApi = CApiConv
631 cvt_conv TH.Prim = PrimCallConv
632 cvt_conv TH.JavaScript = JavaScriptCallConv
633
634 ------------------------------------------
635 -- Pragmas
636 ------------------------------------------
637
638 cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl RdrName))
639 cvtPragmaD (InlineP nm inline rm phases)
640 = do { nm' <- vNameL nm
641 ; let dflt = dfltActivation inline
642 ; let src TH.NoInline = "{-# NOINLINE"
643 src TH.Inline = "{-# INLINE"
644 src TH.Inlinable = "{-# INLINABLE"
645 ; let ip = InlinePragma { inl_src = SourceText $ src inline
646 , inl_inline = cvtInline inline
647 , inl_rule = cvtRuleMatch rm
648 , inl_act = cvtPhases phases dflt
649 , inl_sat = Nothing }
650 ; returnJustL $ Hs.SigD $ InlineSig nm' ip }
651
652 cvtPragmaD (SpecialiseP nm ty inline phases)
653 = do { nm' <- vNameL nm
654 ; ty' <- cvtType ty
655 ; let src TH.NoInline = "{-# SPECIALISE NOINLINE"
656 src TH.Inline = "{-# SPECIALISE INLINE"
657 src TH.Inlinable = "{-# SPECIALISE INLINE"
658 ; let (inline', dflt,srcText) = case inline of
659 Just inline1 -> (cvtInline inline1, dfltActivation inline1,
660 src inline1)
661 Nothing -> (EmptyInlineSpec, AlwaysActive,
662 "{-# SPECIALISE")
663 ; let ip = InlinePragma { inl_src = SourceText srcText
664 , inl_inline = inline'
665 , inl_rule = Hs.FunLike
666 , inl_act = cvtPhases phases dflt
667 , inl_sat = Nothing }
668 ; returnJustL $ Hs.SigD $ SpecSig nm' [mkLHsSigType ty'] ip }
669
670 cvtPragmaD (SpecialiseInstP ty)
671 = do { ty' <- cvtType ty
672 ; returnJustL $ Hs.SigD $
673 SpecInstSig (SourceText "{-# SPECIALISE") (mkLHsSigType ty') }
674
675 cvtPragmaD (RuleP nm bndrs lhs rhs phases)
676 = do { let nm' = mkFastString nm
677 ; let act = cvtPhases phases AlwaysActive
678 ; bndrs' <- mapM cvtRuleBndr bndrs
679 ; lhs' <- cvtl lhs
680 ; rhs' <- cvtl rhs
681 ; returnJustL $ Hs.RuleD
682 $ HsRules (SourceText "{-# RULES")
683 [noLoc $ HsRule (noLoc (SourceText nm,nm')) act bndrs'
684 lhs' placeHolderNames
685 rhs' placeHolderNames]
686 }
687
688 cvtPragmaD (AnnP target exp)
689 = do { exp' <- cvtl exp
690 ; target' <- case target of
691 ModuleAnnotation -> return ModuleAnnProvenance
692 TypeAnnotation n -> do
693 n' <- tconName n
694 return (TypeAnnProvenance (noLoc n'))
695 ValueAnnotation n -> do
696 n' <- vcName n
697 return (ValueAnnProvenance (noLoc n'))
698 ; returnJustL $ Hs.AnnD $ HsAnnotation (SourceText "{-# ANN") target'
699 exp'
700 }
701
702 cvtPragmaD (LineP line file)
703 = do { setL (srcLocSpan (mkSrcLoc (fsLit file) line 1))
704 ; return Nothing
705 }
706 cvtPragmaD (CompleteP cls mty)
707 = do { cls' <- noLoc <$> mapM cNameL cls
708 ; mty' <- traverse tconNameL mty
709 ; returnJustL $ Hs.SigD
710 $ CompleteMatchSig NoSourceText cls' mty' }
711
712 dfltActivation :: TH.Inline -> Activation
713 dfltActivation TH.NoInline = NeverActive
714 dfltActivation _ = AlwaysActive
715
716 cvtInline :: TH.Inline -> Hs.InlineSpec
717 cvtInline TH.NoInline = Hs.NoInline
718 cvtInline TH.Inline = Hs.Inline
719 cvtInline TH.Inlinable = Hs.Inlinable
720
721 cvtRuleMatch :: TH.RuleMatch -> RuleMatchInfo
722 cvtRuleMatch TH.ConLike = Hs.ConLike
723 cvtRuleMatch TH.FunLike = Hs.FunLike
724
725 cvtPhases :: TH.Phases -> Activation -> Activation
726 cvtPhases AllPhases dflt = dflt
727 cvtPhases (FromPhase i) _ = ActiveAfter NoSourceText i
728 cvtPhases (BeforePhase i) _ = ActiveBefore NoSourceText i
729
730 cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr RdrName)
731 cvtRuleBndr (RuleVar n)
732 = do { n' <- vNameL n
733 ; return $ noLoc $ Hs.RuleBndr n' }
734 cvtRuleBndr (TypedRuleVar n ty)
735 = do { n' <- vNameL n
736 ; ty' <- cvtType ty
737 ; return $ noLoc $ Hs.RuleBndrSig n' $ mkLHsSigWcType ty' }
738
739 ---------------------------------------------------
740 -- Declarations
741 ---------------------------------------------------
742
743 cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds RdrName)
744 cvtLocalDecs doc ds
745 | null ds
746 = return EmptyLocalBinds
747 | otherwise
748 = do { ds' <- cvtDecs ds
749 ; let (binds, prob_sigs) = partitionWith is_bind ds'
750 ; let (sigs, bads) = partitionWith is_sig prob_sigs
751 ; unless (null bads) (failWith (mkBadDecMsg doc bads))
752 ; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) }
753
754 cvtClause :: HsMatchContext RdrName
755 -> TH.Clause -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName))
756 cvtClause ctxt (Clause ps body wheres)
757 = do { ps' <- cvtPats ps
758 ; pps <- mapM wrap_conpat ps'
759 ; g' <- cvtGuard body
760 ; ds' <- cvtLocalDecs (text "a where clause") wheres
761 ; returnL $ Hs.Match ctxt pps Nothing
762 (GRHSs g' (noLoc ds')) }
763
764
765 -------------------------------------------------------------------
766 -- Expressions
767 -------------------------------------------------------------------
768
769 cvtl :: TH.Exp -> CvtM (LHsExpr RdrName)
770 cvtl e = wrapL (cvt e)
771 where
772 cvt (VarE s) = do { s' <- vName s; return $ HsVar (noLoc s') }
773 cvt (ConE s) = do { s' <- cName s; return $ HsVar (noLoc s') }
774 cvt (LitE l)
775 | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }
776 | otherwise = do { l' <- cvtLit l; return $ HsLit l' }
777 cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y
778 ; return $ HsApp (mkLHsPar x') (mkLHsPar y')}
779 cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y
780 ; return $ HsApp (mkLHsPar x') (mkLHsPar y')}
781 cvt (AppTypeE e t) = do { e' <- cvtl e
782 ; t' <- cvtType t
783 ; tp <- wrap_apps t'
784 ; return $ HsAppType e' $ mkHsWildCardBndrs tp }
785 cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e
786 ; return $ HsLam (mkMatchGroup FromSource
787 [mkSimpleMatch LambdaExpr ps' e'])}
788 cvt (LamCaseE ms) = do { ms' <- mapM (cvtMatch LambdaExpr) ms
789 ; return $ HsLamCase (mkMatchGroup FromSource ms')
790 }
791 cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar e' }
792 -- Note [Dropping constructors]
793 -- Singleton tuples treated like nothing (just parens)
794 cvt (TupE es) = do { es' <- mapM cvtl es
795 ; return $ ExplicitTuple (map (noLoc . Present) es')
796 Boxed }
797 cvt (UnboxedTupE es) = do { es' <- mapM cvtl es
798 ; return $ ExplicitTuple
799 (map (noLoc . Present) es') Unboxed }
800 cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e
801 ; unboxedSumChecks alt arity
802 ; return $ ExplicitSum
803 alt arity e' placeHolderType }
804 cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
805 ; return $ HsIf (Just noSyntaxExpr) x' y' z' }
806 cvt (MultiIfE alts)
807 | null alts = failWith (text "Multi-way if-expression with no alternatives")
808 | otherwise = do { alts' <- mapM cvtpair alts
809 ; return $ HsMultiIf placeHolderType alts' }
810 cvt (LetE ds e) = do { ds' <- cvtLocalDecs (text "a let expression") ds
811 ; e' <- cvtl e; return $ HsLet (noLoc ds') e' }
812 cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms
813 ; return $ HsCase e' (mkMatchGroup FromSource ms') }
814 cvt (DoE ss) = cvtHsDo DoExpr ss
815 cvt (CompE ss) = cvtHsDo ListComp ss
816 cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr Nothing dd' }
817 cvt (ListE xs)
818 | Just s <- allCharLs xs = do { l' <- cvtLit (StringL s); return (HsLit l') }
819 -- Note [Converting strings]
820 | otherwise = do { xs' <- mapM cvtl xs
821 ; return $ ExplicitList placeHolderType Nothing xs'
822 }
823
824 -- Infix expressions
825 cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
826 ; wrapParL HsPar $
827 OpApp (mkLHsPar x') s' undefined (mkLHsPar y') }
828 -- Parenthesise both arguments and result,
829 -- to ensure this operator application does
830 -- does not get re-associated
831 -- See Note [Operator association]
832 cvt (InfixE Nothing s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
833 ; wrapParL HsPar $ SectionR s' y' }
834 -- See Note [Sections in HsSyn] in HsExpr
835 cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
836 ; wrapParL HsPar $ SectionL x' s' }
837
838 cvt (InfixE Nothing s Nothing ) = do { s' <- cvtl s; return $ HsPar s' }
839 -- Can I indicate this is an infix thing?
840 -- Note [Dropping constructors]
841
842 cvt (UInfixE x s y) = do { x' <- cvtl x
843 ; let x'' = case x' of
844 L _ (OpApp {}) -> x'
845 _ -> mkLHsPar x'
846 ; cvtOpApp x'' s y } -- Note [Converting UInfix]
847
848 cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar e' }
849 cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t
850 ; return $ ExprWithTySig e' (mkLHsSigWcType t') }
851 cvt (RecConE c flds) = do { c' <- cNameL c
852 ; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds
853 ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) }
854 cvt (RecUpdE e flds) = do { e' <- cvtl e
855 ; flds'
856 <- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc))
857 flds
858 ; return $ mkRdrRecordUpd e' flds' }
859 cvt (StaticE e) = fmap (HsStatic placeHolderNames) $ cvtl e
860 cvt (UnboundVarE s) = do { s' <- vName s; return $ HsVar (noLoc s') }
861
862 {- Note [Dropping constructors]
863 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
864 When we drop constructors from the input (for instance, when we encounter @TupE [e]@)
865 we must insert parentheses around the argument. Otherwise, @UInfix@ constructors in @e@
866 could meet @UInfix@ constructors containing the @TupE [e]@. For example:
867
868 UInfixE x * (TupE [UInfixE y + z])
869
870 If we drop the singleton tuple but don't insert parentheses, the @UInfixE@s would meet
871 and the above expression would be reassociated to
872
873 OpApp (OpApp x * y) + z
874
875 which we don't want.
876 -}
877
878 cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp) -> CvtM (LHsRecField' t (LHsExpr RdrName))
879 cvtFld f (v,e)
880 = do { v' <- vNameL v; e' <- cvtl e
881 ; return (noLoc $ HsRecField { hsRecFieldLbl = fmap f v'
882 , hsRecFieldArg = e'
883 , hsRecPun = False}) }
884
885 cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)
886 cvtDD (FromR x) = do { x' <- cvtl x; return $ From x' }
887 cvtDD (FromThenR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }
888 cvtDD (FromToR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
889 cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }
890
891 {- Note [Operator assocation]
892 We must be quite careful about adding parens:
893 * Infix (UInfix ...) op arg Needs parens round the first arg
894 * Infix (Infix ...) op arg Needs parens round the first arg
895 * UInfix (UInfix ...) op arg No parens for first arg
896 * UInfix (Infix ...) op arg Needs parens round first arg
897
898
899 Note [Converting UInfix]
900 ~~~~~~~~~~~~~~~~~~~~~~~~
901 When converting @UInfixE@, @UInfixP@, and @UInfixT@ values, we want to readjust
902 the trees to reflect the fixities of the underlying operators:
903
904 UInfixE x * (UInfixE y + z) ---> (x * y) + z
905
906 This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and
907 @mkHsOpTyRn@ in RnTypes), which expects that the input will be completely
908 right-biased for types and left-biased for everything else. So we left-bias the
909 trees of @UInfixP@ and @UInfixE@ and use HsAppsTy for UInfixT.
910
911 Sample input:
912
913 UInfixE
914 (UInfixE x op1 y)
915 op2
916 (UInfixE z op3 w)
917
918 Sample output:
919
920 OpApp
921 (OpApp
922 (OpApp x op1 y)
923 op2
924 z)
925 op3
926 w
927
928 The functions @cvtOpApp@, @cvtOpAppP@, and @cvtOpAppT@ are responsible for this
929 biasing.
930 -}
931
932 {- | @cvtOpApp x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
933 The produced tree of infix expressions will be left-biased, provided @x@ is.
934
935 We can see that @cvtOpApp@ is correct as follows. The inductive hypothesis
936 is that @cvtOpApp x op y@ is left-biased, provided @x@ is. It is clear that
937 this holds for both branches (of @cvtOpApp@), provided we assume it holds for
938 the recursive calls to @cvtOpApp@.
939
940 When we call @cvtOpApp@ from @cvtl@, the first argument will always be left-biased
941 since we have already run @cvtl@ on it.
942 -}
943 cvtOpApp :: LHsExpr RdrName -> TH.Exp -> TH.Exp -> CvtM (HsExpr RdrName)
944 cvtOpApp x op1 (UInfixE y op2 z)
945 = do { l <- wrapL $ cvtOpApp x op1 y
946 ; cvtOpApp l op2 z }
947 cvtOpApp x op y
948 = do { op' <- cvtl op
949 ; y' <- cvtl y
950 ; return (OpApp x op' undefined y') }
951
952 -------------------------------------
953 -- Do notation and statements
954 -------------------------------------
955
956 cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr RdrName)
957 cvtHsDo do_or_lc stmts
958 | null stmts = failWith (text "Empty stmt list in do-block")
959 | otherwise
960 = do { stmts' <- cvtStmts stmts
961 ; let Just (stmts'', last') = snocView stmts'
962
963 ; last'' <- case last' of
964 L loc (BodyStmt body _ _ _) -> return (L loc (mkLastStmt body))
965 _ -> failWith (bad_last last')
966
967 ; return $ HsDo do_or_lc (noLoc (stmts'' ++ [last''])) placeHolderType }
968 where
969 bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAStmtContext do_or_lc <> colon
970 , nest 2 $ Outputable.ppr stmt
971 , text "(It should be an expression.)" ]
972
973 cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName (LHsExpr RdrName)]
974 cvtStmts = mapM cvtStmt
975
976 cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName (LHsExpr RdrName))
977 cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkBodyStmt e' }
978 cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
979 cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (text "a let binding") ds
980 ; returnL $ LetStmt (noLoc ds') }
981 cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noExpr noSyntaxExpr placeHolderType }
982 where
983 cvt_one ds = do { ds' <- cvtStmts ds; return (ParStmtBlock ds' undefined noSyntaxExpr) }
984
985 cvtMatch :: HsMatchContext RdrName
986 -> TH.Match -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName))
987 cvtMatch ctxt (TH.Match p body decs)
988 = do { p' <- cvtPat p
989 ; lp <- case ctxt of
990 CaseAlt -> return p'
991 _ -> wrap_conpat p'
992 ; g' <- cvtGuard body
993 ; decs' <- cvtLocalDecs (text "a where clause") decs
994 ; returnL $ Hs.Match ctxt [lp] Nothing
995 (GRHSs g' (noLoc decs')) }
996
997 cvtGuard :: TH.Body -> CvtM [LGRHS RdrName (LHsExpr RdrName)]
998 cvtGuard (GuardedB pairs) = mapM cvtpair pairs
999 cvtGuard (NormalB e) = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] }
1000
1001 cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName (LHsExpr RdrName))
1002 cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
1003 ; g' <- returnL $ mkBodyStmt ge'
1004 ; returnL $ GRHS [g'] rhs' }
1005 cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
1006 ; returnL $ GRHS gs' rhs' }
1007
1008 cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
1009 cvtOverLit (IntegerL i)
1010 = do { force i; return $ mkHsIntegral (mkIntegralLit i) placeHolderType}
1011 cvtOverLit (RationalL r)
1012 = do { force r; return $ mkHsFractional (mkFractionalLit r) placeHolderType}
1013 cvtOverLit (StringL s)
1014 = do { let { s' = mkFastString s }
1015 ; force s'
1016 ; return $ mkHsIsString (quotedSourceText s) s' placeHolderType
1017 }
1018 cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
1019 -- An Integer is like an (overloaded) '3' in a Haskell source program
1020 -- Similarly 3.5 for fractionals
1021
1022 {- Note [Converting strings]
1023 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1024 If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to
1025 a string literal for "xy". Of course, we might hope to get
1026 (LitE (StringL "xy")), but not always, and allCharLs fails quickly
1027 if it isn't a literal string
1028 -}
1029
1030 allCharLs :: [TH.Exp] -> Maybe String
1031 -- Note [Converting strings]
1032 -- NB: only fire up this setup for a non-empty list, else
1033 -- there's a danger of returning "" for [] :: [Int]!
1034 allCharLs xs
1035 = case xs of
1036 LitE (CharL c) : ys -> go [c] ys
1037 _ -> Nothing
1038 where
1039 go cs [] = Just (reverse cs)
1040 go cs (LitE (CharL c) : ys) = go (c:cs) ys
1041 go _ _ = Nothing
1042
1043 cvtLit :: Lit -> CvtM HsLit
1044 cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim NoSourceText i }
1045 cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim NoSourceText w }
1046 cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim (mkFractionalLit f) }
1047 cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim (mkFractionalLit f) }
1048 cvtLit (CharL c) = do { force c; return $ HsChar NoSourceText c }
1049 cvtLit (CharPrimL c) = do { force c; return $ HsCharPrim NoSourceText c }
1050 cvtLit (StringL s) = do { let { s' = mkFastString s }
1051 ; force s'
1052 ; return $ HsString (quotedSourceText s) s' }
1053 cvtLit (StringPrimL s) = do { let { s' = BS.pack s }
1054 ; force s'
1055 ; return $ HsStringPrim NoSourceText s' }
1056 cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
1057 -- cvtLit should not be called on IntegerL, RationalL
1058 -- That precondition is established right here in
1059 -- Convert.hs, hence panic
1060
1061 quotedSourceText :: String -> SourceText
1062 quotedSourceText s = SourceText $ "\"" ++ s ++ "\""
1063
1064 cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName]
1065 cvtPats pats = mapM cvtPat pats
1066
1067 cvtPat :: TH.Pat -> CvtM (Hs.LPat RdrName)
1068 cvtPat pat = wrapL (cvtp pat)
1069
1070 cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName)
1071 cvtp (TH.LitP l)
1072 | overloadedLit l = do { l' <- cvtOverLit l
1073 ; return (mkNPat (noLoc l') Nothing) }
1074 -- Not right for negative patterns;
1075 -- need to think about that!
1076 | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat l' }
1077 cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat (noLoc s') }
1078 cvtp (TupP [p]) = do { p' <- cvtPat p; return $ ParPat p' } -- Note [Dropping constructors]
1079 cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed [] }
1080 cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed [] }
1081 cvtp (UnboxedSumP p alt arity)
1082 = do { p' <- cvtPat p
1083 ; unboxedSumChecks alt arity
1084 ; return $ SumPat p' alt arity placeHolderType }
1085 cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps
1086 ; pps <- mapM wrap_conpat ps'
1087 ; return $ ConPatIn s' (PrefixCon pps) }
1088 cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
1089 ; wrapParL ParPat $
1090 ConPatIn s' (InfixCon (mkParPat p1') (mkParPat p2')) }
1091 -- See Note [Operator association]
1092 cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix]
1093 cvtp (ParensP p) = do { p' <- cvtPat p;
1094 ; case p' of -- may be wrapped ConPatIn
1095 (L _ (ParPat {})) -> return $ unLoc p'
1096 _ -> return $ ParPat p' }
1097 cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat p' }
1098 cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat p' }
1099 cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
1100 cvtp TH.WildP = return $ WildPat placeHolderType
1101 cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
1102 ; return $ ConPatIn c'
1103 $ Hs.RecCon (HsRecFields fs' Nothing) }
1104 cvtp (ListP ps) = do { ps' <- cvtPats ps
1105 ; return $ ListPat ps' placeHolderType Nothing }
1106 cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t
1107 ; return $ SigPatIn p' (mkLHsSigWcType t') }
1108 cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p
1109 ; return $ ViewPat e' p' placeHolderType }
1110
1111 cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField RdrName (LPat RdrName))
1112 cvtPatFld (s,p)
1113 = do { L ls s' <- vNameL s; p' <- cvtPat p
1114 ; return (noLoc $ HsRecField { hsRecFieldLbl
1115 = L ls $ mkFieldOcc (L ls s')
1116 , hsRecFieldArg = p'
1117 , hsRecPun = False}) }
1118
1119 wrap_conpat :: Hs.LPat RdrName -> CvtM (Hs.LPat RdrName)
1120 wrap_conpat p@(L _ (ConPatIn _ (InfixCon{}))) = returnL $ ParPat p
1121 wrap_conpat p@(L _ (ConPatIn _ (PrefixCon []))) = return p
1122 wrap_conpat p@(L _ (ConPatIn _ (PrefixCon _))) = returnL $ ParPat p
1123 wrap_conpat p = return p
1124
1125 {- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
1126 The produced tree of infix patterns will be left-biased, provided @x@ is.
1127
1128 See the @cvtOpApp@ documentation for how this function works.
1129 -}
1130 cvtOpAppP :: Hs.LPat RdrName -> TH.Name -> TH.Pat -> CvtM (Hs.Pat RdrName)
1131 cvtOpAppP x op1 (UInfixP y op2 z)
1132 = do { l <- wrapL $ cvtOpAppP x op1 y
1133 ; cvtOpAppP l op2 z }
1134 cvtOpAppP x op y
1135 = do { op' <- cNameL op
1136 ; y' <- cvtPat y
1137 ; return (ConPatIn op' (InfixCon x y')) }
1138
1139 -----------------------------------------------------------
1140 -- Types and type variables
1141
1142 cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsQTyVars RdrName)
1143 cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') }
1144
1145 cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
1146 cvt_tv (TH.PlainTV nm)
1147 = do { nm' <- tNameL nm
1148 ; returnL $ UserTyVar nm' }
1149 cvt_tv (TH.KindedTV nm ki)
1150 = do { nm' <- tNameL nm
1151 ; ki' <- cvtKind ki
1152 ; returnL $ KindedTyVar nm' ki' }
1153
1154 cvtRole :: TH.Role -> Maybe Coercion.Role
1155 cvtRole TH.NominalR = Just Coercion.Nominal
1156 cvtRole TH.RepresentationalR = Just Coercion.Representational
1157 cvtRole TH.PhantomR = Just Coercion.Phantom
1158 cvtRole TH.InferR = Nothing
1159
1160 cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
1161 cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
1162
1163 cvtPred :: TH.Pred -> CvtM (LHsType RdrName)
1164 cvtPred = cvtType
1165
1166 cvtDerivClause :: TH.DerivClause
1167 -> CvtM (LHsDerivingClause RdrName)
1168 cvtDerivClause (TH.DerivClause ds ctxt)
1169 = do { ctxt'@(L loc _) <- fmap (map mkLHsSigType) <$> cvtContext ctxt
1170 ; let ds' = fmap (L loc . cvtDerivStrategy) ds
1171 ; returnL $ HsDerivingClause ds' ctxt' }
1172
1173 cvtDerivStrategy :: TH.DerivStrategy -> Hs.DerivStrategy
1174 cvtDerivStrategy TH.StockStrategy = Hs.StockStrategy
1175 cvtDerivStrategy TH.AnyclassStrategy = Hs.AnyclassStrategy
1176 cvtDerivStrategy TH.NewtypeStrategy = Hs.NewtypeStrategy
1177
1178 cvtType :: TH.Type -> CvtM (LHsType RdrName)
1179 cvtType = cvtTypeKind "type"
1180
1181 cvtTypeKind :: String -> TH.Type -> CvtM (LHsType RdrName)
1182 cvtTypeKind ty_str ty
1183 = do { (head_ty, tys') <- split_ty_app ty
1184 ; case head_ty of
1185 TupleT n
1186 | length tys' == n -- Saturated
1187 -> if n==1 then return (head tys') -- Singleton tuples treated
1188 -- like nothing (ie just parens)
1189 else returnL (HsTupleTy HsBoxedOrConstraintTuple tys')
1190 | n == 1
1191 -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor")))
1192 | otherwise
1193 -> mk_apps (HsTyVar NotPromoted
1194 (noLoc (getRdrName (tupleTyCon Boxed n)))) tys'
1195 UnboxedTupleT n
1196 | length tys' == n -- Saturated
1197 -> returnL (HsTupleTy HsUnboxedTuple tys')
1198 | otherwise
1199 -> mk_apps (HsTyVar NotPromoted
1200 (noLoc (getRdrName (tupleTyCon Unboxed n)))) tys'
1201 UnboxedSumT n
1202 | n < 2
1203 -> failWith $
1204 vcat [ text "Illegal sum arity:" <+> text (show n)
1205 , nest 2 $
1206 text "Sums must have an arity of at least 2" ]
1207 | length tys' == n -- Saturated
1208 -> returnL (HsSumTy tys')
1209 | otherwise
1210 -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName (sumTyCon n))))
1211 tys'
1212 ArrowT
1213 | [x',y'] <- tys' -> do
1214 case x' of
1215 (L _ HsFunTy{}) -> do { x'' <- returnL (HsParTy x')
1216 ; returnL (HsFunTy x'' y') }
1217 _ -> returnL (HsFunTy x' y')
1218 | otherwise ->
1219 mk_apps (HsTyVar NotPromoted (noLoc (getRdrName funTyCon)))
1220 tys'
1221 ListT
1222 | [x'] <- tys' -> returnL (HsListTy x')
1223 | otherwise ->
1224 mk_apps (HsTyVar NotPromoted (noLoc (getRdrName listTyCon)))
1225 tys'
1226 VarT nm -> do { nm' <- tNameL nm
1227 ; mk_apps (HsTyVar NotPromoted nm') tys' }
1228 ConT nm -> do { nm' <- tconName nm
1229 ; mk_apps (HsTyVar NotPromoted (noLoc nm')) tys' }
1230
1231 ForallT tvs cxt ty
1232 | null tys'
1233 -> do { tvs' <- cvtTvs tvs
1234 ; cxt' <- cvtContext cxt
1235 ; ty' <- cvtType ty
1236 ; loc <- getL
1237 ; let hs_ty = mkHsForAllTy tvs loc tvs' rho_ty
1238 rho_ty = mkHsQualTy cxt loc cxt' ty'
1239
1240 ; return hs_ty }
1241
1242 SigT ty ki
1243 -> do { ty' <- cvtType ty
1244 ; ki' <- cvtKind ki
1245 ; mk_apps (HsKindSig ty' ki') tys'
1246 }
1247
1248 LitT lit
1249 -> returnL (HsTyLit (cvtTyLit lit))
1250
1251 WildCardT
1252 -> mk_apps mkAnonWildCardTy tys'
1253
1254 InfixT t1 s t2
1255 -> do { s' <- tconName s
1256 ; t1' <- cvtType t1
1257 ; t2' <- cvtType t2
1258 ; mk_apps (HsTyVar NotPromoted (noLoc s')) [t1', t2']
1259 }
1260
1261 UInfixT t1 s t2
1262 -> do { t1' <- cvtType t1
1263 ; t2' <- cvtType t2
1264 ; s' <- tconName s
1265 ; return $ cvtOpAppT t1' s' t2'
1266 } -- Note [Converting UInfix]
1267
1268 ParensT t
1269 -> do { t' <- cvtType t
1270 ; returnL $ HsParTy t'
1271 }
1272
1273 PromotedT nm -> do { nm' <- cName nm
1274 ; mk_apps (HsTyVar NotPromoted (noLoc nm')) tys' }
1275 -- Promoted data constructor; hence cName
1276
1277 PromotedTupleT n
1278 | n == 1
1279 -> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str)))
1280 | m == n -- Saturated
1281 -> do { let kis = replicate m placeHolderKind
1282 ; returnL (HsExplicitTupleTy kis tys')
1283 }
1284 where
1285 m = length tys'
1286
1287 PromotedNilT
1288 -> returnL (HsExplicitListTy Promoted placeHolderKind [])
1289
1290 PromotedConsT -- See Note [Representing concrete syntax in types]
1291 -- in Language.Haskell.TH.Syntax
1292 | [ty1, L _ (HsExplicitListTy ip _ tys2)] <- tys'
1293 -> returnL (HsExplicitListTy ip placeHolderKind (ty1:tys2))
1294 | otherwise
1295 -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName consDataCon)))
1296 tys'
1297
1298 StarT
1299 -> returnL (HsTyVar NotPromoted (noLoc
1300 (getRdrName liftedTypeKindTyCon)))
1301
1302 ConstraintT
1303 -> returnL (HsTyVar NotPromoted
1304 (noLoc (getRdrName constraintKindTyCon)))
1305
1306 EqualityT
1307 | [x',y'] <- tys' -> returnL (HsEqTy x' y')
1308 | otherwise ->
1309 mk_apps (HsTyVar NotPromoted
1310 (noLoc (getRdrName eqPrimTyCon))) tys'
1311
1312 _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))
1313 }
1314
1315 -- | Constructs an application of a type to arguments passed in a list.
1316 mk_apps :: HsType RdrName -> [LHsType RdrName] -> CvtM (LHsType RdrName)
1317 mk_apps head_ty [] = returnL head_ty
1318 mk_apps head_ty (ty:tys) =
1319 do { head_ty' <- returnL head_ty
1320 ; p_ty <- add_parens ty
1321 ; mk_apps (HsAppTy head_ty' p_ty) tys }
1322 where
1323 add_parens t@(L _ HsAppTy{}) = returnL (HsParTy t)
1324 add_parens t = return t
1325
1326 wrap_apps :: LHsType RdrName -> CvtM (LHsType RdrName)
1327 wrap_apps t@(L _ HsAppTy {}) = returnL (HsParTy t)
1328 wrap_apps t = return t
1329
1330 -- | Constructs an arrow type with a specified return type
1331 mk_arr_apps :: [LHsType RdrName] -> HsType RdrName -> CvtM (LHsType RdrName)
1332 mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL
1333 where go :: LHsType RdrName -> HsType RdrName -> CvtM (HsType RdrName)
1334 go arg ret_ty = do { ret_ty_l <- returnL ret_ty
1335 ; return (HsFunTy arg ret_ty_l) }
1336
1337 split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
1338 split_ty_app ty = go ty []
1339 where
1340 go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
1341 go f as = return (f,as)
1342
1343 cvtTyLit :: TH.TyLit -> HsTyLit
1344 cvtTyLit (TH.NumTyLit i) = HsNumTy NoSourceText i
1345 cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s)
1346
1347 {- | @cvtOpAppT x op y@ takes converted arguments and flattens any HsAppsTy
1348 structure in them.
1349 -}
1350 cvtOpAppT :: LHsType RdrName -> RdrName -> LHsType RdrName -> LHsType RdrName
1351 cvtOpAppT t1@(L loc1 _) op t2@(L loc2 _)
1352 = L (combineSrcSpans loc1 loc2) $
1353 HsAppsTy (t1' ++ [noLoc $ HsAppInfix (noLoc op)] ++ t2')
1354 where
1355 t1' | L _ (HsAppsTy t1s) <- t1
1356 = t1s
1357 | otherwise
1358 = [noLoc $ HsAppPrefix t1]
1359
1360 t2' | L _ (HsAppsTy t2s) <- t2
1361 = t2s
1362 | otherwise
1363 = [noLoc $ HsAppPrefix t2]
1364
1365 cvtKind :: TH.Kind -> CvtM (LHsKind RdrName)
1366 cvtKind = cvtTypeKind "kind"
1367
1368 -- | Convert Maybe Kind to a type family result signature. Used with data
1369 -- families where naming of the result is not possible (thus only kind or no
1370 -- signature is possible).
1371 cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind
1372 -> CvtM (LFamilyResultSig RdrName)
1373 cvtMaybeKindToFamilyResultSig Nothing = returnL Hs.NoSig
1374 cvtMaybeKindToFamilyResultSig (Just ki) = do { ki' <- cvtKind ki
1375 ; returnL (Hs.KindSig ki') }
1376
1377 -- | Convert type family result signature. Used with both open and closed type
1378 -- families.
1379 cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig RdrName)
1380 cvtFamilyResultSig TH.NoSig = returnL Hs.NoSig
1381 cvtFamilyResultSig (TH.KindSig ki) = do { ki' <- cvtKind ki
1382 ; returnL (Hs.KindSig ki') }
1383 cvtFamilyResultSig (TH.TyVarSig bndr) = do { tv <- cvt_tv bndr
1384 ; returnL (Hs.TyVarSig tv) }
1385
1386 -- | Convert injectivity annotation of a type family.
1387 cvtInjectivityAnnotation :: TH.InjectivityAnn
1388 -> CvtM (Hs.LInjectivityAnn RdrName)
1389 cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS)
1390 = do { annLHS' <- tNameL annLHS
1391 ; annRHS' <- mapM tNameL annRHS
1392 ; returnL (Hs.InjectivityAnn annLHS' annRHS') }
1393
1394 cvtPatSynSigTy :: TH.Type -> CvtM (LHsType RdrName)
1395 -- pattern synonym types are of peculiar shapes, which is why we treat
1396 -- them separately from regular types;
1397 -- see Note [Pattern synonym type signatures and Template Haskell]
1398 cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))
1399 | null exis, null provs = cvtType (ForallT univs reqs ty)
1400 | null univs, null reqs = do { l <- getL
1401 ; ty' <- cvtType (ForallT exis provs ty)
1402 ; return $ L l (HsQualTy { hst_ctxt = L l []
1403 , hst_body = ty' }) }
1404 | null reqs = do { l <- getL
1405 ; univs' <- hsQTvExplicit <$> cvtTvs univs
1406 ; ty' <- cvtType (ForallT exis provs ty)
1407 ; let forTy = HsForAllTy { hst_bndrs = univs'
1408 , hst_body = L l cxtTy }
1409 cxtTy = HsQualTy { hst_ctxt = L l []
1410 , hst_body = ty' }
1411 ; return $ L l forTy }
1412 | otherwise = cvtType (ForallT univs reqs (ForallT exis provs ty))
1413 cvtPatSynSigTy ty = cvtType ty
1414
1415 -----------------------------------------------------------
1416 cvtFixity :: TH.Fixity -> Hs.Fixity
1417 cvtFixity (TH.Fixity prec dir) = Hs.Fixity NoSourceText prec (cvt_dir dir)
1418 where
1419 cvt_dir TH.InfixL = Hs.InfixL
1420 cvt_dir TH.InfixR = Hs.InfixR
1421 cvt_dir TH.InfixN = Hs.InfixN
1422
1423 -----------------------------------------------------------
1424
1425
1426 -----------------------------------------------------------
1427 -- some useful things
1428
1429 overloadedLit :: Lit -> Bool
1430 -- True for literals that Haskell treats as overloaded
1431 overloadedLit (IntegerL _) = True
1432 overloadedLit (RationalL _) = True
1433 overloadedLit _ = False
1434
1435 -- Checks that are performed when converting unboxed sum expressions and
1436 -- patterns alike.
1437 unboxedSumChecks :: TH.SumAlt -> TH.SumArity -> CvtM ()
1438 unboxedSumChecks alt arity
1439 | alt > arity
1440 = failWith $ text "Sum alternative" <+> text (show alt)
1441 <+> text "exceeds its arity," <+> text (show arity)
1442 | alt <= 0
1443 = failWith $ vcat [ text "Illegal sum alternative:" <+> text (show alt)
1444 , nest 2 $ text "Sum alternatives must start from 1" ]
1445 | arity < 2
1446 = failWith $ vcat [ text "Illegal sum arity:" <+> text (show arity)
1447 , nest 2 $ text "Sums must have an arity of at least 2" ]
1448 | otherwise
1449 = return ()
1450
1451 -- | If passed an empty list of 'TH.TyVarBndr's, this simply returns the
1452 -- third argument (an 'LHsType'). Otherwise, return an 'HsForAllTy'
1453 -- using the provided 'LHsQTyVars' and 'LHsType'.
1454 mkHsForAllTy :: [TH.TyVarBndr]
1455 -- ^ The original Template Haskell type variable binders
1456 -> SrcSpan
1457 -- ^ The location of the returned 'LHsType' if it needs an
1458 -- explicit forall
1459 -> LHsQTyVars name
1460 -- ^ The converted type variable binders
1461 -> LHsType name
1462 -- ^ The converted rho type
1463 -> LHsType name
1464 -- ^ The complete type, quantified with a forall if necessary
1465 mkHsForAllTy tvs loc tvs' rho_ty
1466 | null tvs = rho_ty
1467 | otherwise = L loc $ HsForAllTy { hst_bndrs = hsQTvExplicit tvs'
1468 , hst_body = rho_ty }
1469
1470 -- | If passed an empty 'TH.Cxt', this simply returns the third argument
1471 -- (an 'LHsType'). Otherwise, return an 'HsQualTy' using the provided
1472 -- 'LHsContext' and 'LHsType'.
1473
1474 -- It's important that we don't build an HsQualTy if the context is empty,
1475 -- as the pretty-printer for HsType _always_ prints contexts, even if
1476 -- they're empty. See Trac #13183.
1477 mkHsQualTy :: TH.Cxt
1478 -- ^ The original Template Haskell context
1479 -> SrcSpan
1480 -- ^ The location of the returned 'LHsType' if it needs an
1481 -- explicit context
1482 -> LHsContext name
1483 -- ^ The converted context
1484 -> LHsType name
1485 -- ^ The converted tau type
1486 -> LHsType name
1487 -- ^ The complete type, qualified with a context if necessary
1488 mkHsQualTy ctxt loc ctxt' ty
1489 | null ctxt = ty
1490 | otherwise = L loc $ HsQualTy { hst_ctxt = ctxt', hst_body = ty }
1491
1492 --------------------------------------------------------------------
1493 -- Turning Name back into RdrName
1494 --------------------------------------------------------------------
1495
1496 -- variable names
1497 vNameL, cNameL, vcNameL, tNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
1498 vName, cName, vcName, tName, tconName :: TH.Name -> CvtM RdrName
1499
1500 -- Variable names
1501 vNameL n = wrapL (vName n)
1502 vName n = cvtName OccName.varName n
1503
1504 -- Constructor function names; this is Haskell source, hence srcDataName
1505 cNameL n = wrapL (cName n)
1506 cName n = cvtName OccName.dataName n
1507
1508 -- Variable *or* constructor names; check by looking at the first char
1509 vcNameL n = wrapL (vcName n)
1510 vcName n = if isVarName n then vName n else cName n
1511
1512 -- Type variable names
1513 tNameL n = wrapL (tName n)
1514 tName n = cvtName OccName.tvName n
1515
1516 -- Type Constructor names
1517 tconNameL n = wrapL (tconName n)
1518 tconName n = cvtName OccName.tcClsName n
1519
1520 cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
1521 cvtName ctxt_ns (TH.Name occ flavour)
1522 | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
1523 | otherwise
1524 = do { loc <- getL
1525 ; let rdr_name = thRdrName loc ctxt_ns occ_str flavour
1526 ; force rdr_name
1527 ; return rdr_name }
1528 where
1529 occ_str = TH.occString occ
1530
1531 okOcc :: OccName.NameSpace -> String -> Bool
1532 okOcc ns str
1533 | OccName.isVarNameSpace ns = okVarOcc str
1534 | OccName.isDataConNameSpace ns = okConOcc str
1535 | otherwise = okTcOcc str
1536
1537 -- Determine the name space of a name in a type
1538 --
1539 isVarName :: TH.Name -> Bool
1540 isVarName (TH.Name occ _)
1541 = case TH.occString occ of
1542 "" -> False
1543 (c:_) -> startsVarId c || startsVarSym c
1544
1545 badOcc :: OccName.NameSpace -> String -> SDoc
1546 badOcc ctxt_ns occ
1547 = text "Illegal" <+> pprNameSpace ctxt_ns
1548 <+> text "name:" <+> quotes (text occ)
1549
1550 thRdrName :: SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
1551 -- This turns a TH Name into a RdrName; used for both binders and occurrences
1552 -- See Note [Binders in Template Haskell]
1553 -- The passed-in name space tells what the context is expecting;
1554 -- use it unless the TH name knows what name-space it comes
1555 -- from, in which case use the latter
1556 --
1557 -- We pass in a SrcSpan (gotten from the monad) because this function
1558 -- is used for *binders* and if we make an Exact Name we want it
1559 -- to have a binding site inside it. (cf Trac #5434)
1560 --
1561 -- ToDo: we may generate silly RdrNames, by passing a name space
1562 -- that doesn't match the string, like VarName ":+",
1563 -- which will give confusing error messages later
1564 --
1565 -- The strict applications ensure that any buried exceptions get forced
1566 thRdrName loc ctxt_ns th_occ th_name
1567 = case th_name of
1568 TH.NameG th_ns pkg mod -> thOrigRdrName th_occ th_ns pkg mod
1569 TH.NameQ mod -> (mkRdrQual $! mk_mod mod) $! occ
1570 TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq uniq) $! occ) loc)
1571 TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq uniq) $! occ) loc)
1572 TH.NameS | Just name <- isBuiltInOcc_maybe occ -> nameRdrName $! name
1573 | otherwise -> mkRdrUnqual $! occ
1574 -- We check for built-in syntax here, because the TH
1575 -- user might have written a (NameS "(,,)"), for example
1576 where
1577 occ :: OccName.OccName
1578 occ = mk_occ ctxt_ns th_occ
1579
1580 thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
1581 thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)
1582
1583 thRdrNameGuesses :: TH.Name -> [RdrName]
1584 thRdrNameGuesses (TH.Name occ flavour)
1585 -- This special case for NameG ensures that we don't generate duplicates in the output list
1586 | TH.NameG th_ns pkg mod <- flavour = [ thOrigRdrName occ_str th_ns pkg mod]
1587 | otherwise = [ thRdrName noSrcSpan gns occ_str flavour
1588 | gns <- guessed_nss]
1589 where
1590 -- guessed_ns are the name spaces guessed from looking at the TH name
1591 guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName, OccName.dataName]
1592 | otherwise = [OccName.varName, OccName.tvName]
1593 occ_str = TH.occString occ
1594
1595 -- The packing and unpacking is rather turgid :-(
1596 mk_occ :: OccName.NameSpace -> String -> OccName.OccName
1597 mk_occ ns occ = OccName.mkOccName ns occ
1598
1599 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
1600 mk_ghc_ns TH.DataName = OccName.dataName
1601 mk_ghc_ns TH.TcClsName = OccName.tcClsName
1602 mk_ghc_ns TH.VarName = OccName.varName
1603
1604 mk_mod :: TH.ModName -> ModuleName
1605 mk_mod mod = mkModuleName (TH.modString mod)
1606
1607 mk_pkg :: TH.PkgName -> UnitId
1608 mk_pkg pkg = stringToUnitId (TH.pkgString pkg)
1609
1610 mk_uniq :: Int -> Unique
1611 mk_uniq u = mkUniqueGrimily u
1612
1613 {-
1614 Note [Binders in Template Haskell]
1615 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1616 Consider this TH term construction:
1617 do { x1 <- TH.newName "x" -- newName :: String -> Q TH.Name
1618 ; x2 <- TH.newName "x" -- Builds a NameU
1619 ; x3 <- TH.newName "x"
1620
1621 ; let x = mkName "x" -- mkName :: String -> TH.Name
1622 -- Builds a NameS
1623
1624 ; return (LamE (..pattern [x1,x2]..) $
1625 LamE (VarPat x3) $
1626 ..tuple (x1,x2,x3,x)) }
1627
1628 It represents the term \[x1,x2]. \x3. (x1,x2,x3,x)
1629
1630 a) We don't want to complain about "x" being bound twice in
1631 the pattern [x1,x2]
1632 b) We don't want x3 to shadow the x1,x2
1633 c) We *do* want 'x' (dynamically bound with mkName) to bind
1634 to the innermost binding of "x", namely x3.
1635 d) When pretty printing, we want to print a unique with x1,x2
1636 etc, else they'll all print as "x" which isn't very helpful
1637
1638 When we convert all this to HsSyn, the TH.Names are converted with
1639 thRdrName. To achieve (b) we want the binders to be Exact RdrNames.
1640 Achieving (a) is a bit awkward, because
1641 - We must check for duplicate and shadowed names on Names,
1642 not RdrNames, *after* renaming.
1643 See Note [Collect binders only after renaming] in HsUtils
1644
1645 - But to achieve (a) we must distinguish between the Exact
1646 RdrNames arising from TH and the Unqual RdrNames that would
1647 come from a user writing \[x,x] -> blah
1648
1649 So in Convert.thRdrName we translate
1650 TH Name RdrName
1651 --------------------------------------------------------
1652 NameU (arising from newName) --> Exact (Name{ System })
1653 NameS (arising from mkName) --> Unqual
1654
1655 Notice that the NameUs generate *System* Names. Then, when
1656 figuring out shadowing and duplicates, we can filter out
1657 System Names.
1658
1659 This use of System Names fits with other uses of System Names, eg for
1660 temporary variables "a". Since there are lots of things called "a" we
1661 usually want to print the name with the unique, and that is indeed
1662 the way System Names are printed.
1663
1664 There's a small complication of course; see Note [Looking up Exact
1665 RdrNames] in RnEnv.
1666 -}
1667
1668 {-
1669 Note [Pattern synonym type signatures and Template Haskell]
1670 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1671
1672 In general, the type signature of a pattern synonym
1673
1674 pattern P x1 x2 .. xn = <some-pattern>
1675
1676 is of the form
1677
1678 forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t
1679
1680 with the following parts:
1681
1682 1) the (possibly empty lists of) universally quantified type
1683 variables `univs` and required constraints `reqs` on them.
1684 2) the (possibly empty lists of) existentially quantified type
1685 variables `exis` and the provided constraints `provs` on them.
1686 3) the types `t1`, `t2`, .., `tn` of the pattern synonym's arguments x1,
1687 x2, .., xn, respectively
1688 4) the type `t` of <some-pattern>, mentioning only universals from `univs`.
1689
1690 Due to the two forall quantifiers and constraint contexts (either of
1691 which might be empty), pattern synonym type signatures are treated
1692 specially in `deSugar/DsMeta.hs`, `hsSyn/Convert.hs`, and
1693 `typecheck/TcSplice.hs`:
1694
1695 (a) When desugaring a pattern synonym from HsSyn to TH.Dec in
1696 `deSugar/DsMeta.hs`, we represent its *full* type signature in TH, i.e.:
1697
1698 ForallT univs reqs (ForallT exis provs ty)
1699 (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)
1700
1701 (b) When converting pattern synonyms from TH.Dec to HsSyn in
1702 `hsSyn/Convert.hs`, we convert their TH type signatures back to an
1703 appropriate Haskell pattern synonym type of the form
1704
1705 forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t
1706
1707 where initial empty `univs` type variables or an empty `reqs`
1708 constraint context are represented *explicitly* as `() =>`.
1709
1710 (c) When reifying a pattern synonym in `typecheck/TcSplice.hs`, we always
1711 return its *full* type, i.e.:
1712
1713 ForallT univs reqs (ForallT exis provs ty)
1714 (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)
1715
1716 The key point is to always represent a pattern synonym's *full* type
1717 in cases (a) and (c) to make it clear which of the two forall
1718 quantifiers and/or constraint contexts are specified, and which are
1719 not. See GHC's user's guide on pattern synonyms for more information
1720 about pattern synonym type signatures.
1721
1722 -}