Convert.hs 59.7 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1
2
3
4
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

5
6

This module converts Template Haskell syntax into HsSyn
Austin Seipp's avatar
Austin Seipp committed
7
-}
8

Matthew Pickering's avatar
Matthew Pickering committed
9
{-# LANGUAGE ScopedTypeVariables #-}
10

11
module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
batterseapower's avatar
batterseapower committed
12
                convertToHsType,
13
                thRdrNameGuesses ) where
14
15

import HsSyn as Hs
16
17
18
19
20
import qualified Class
import RdrName
import qualified Name
import Module
import RdrHsSyn
21
import qualified OccName
22
23
24
import OccName
import SrcLoc
import Type
25
import qualified Coercion ( Role(..) )
26
import TysWiredIn
27
import TysPrim (eqPrimTyCon)
28
import BasicTypes as Hs
29
30
31
32
import ForeignCall
import Unique
import ErrUtils
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
Austin Seipp's avatar
Austin Seipp committed
40
import Control.Monad( unless, liftM, ap )
41

Alan Zimmerman's avatar
Alan Zimmerman committed
42
43
import Data.Char ( chr )
import Data.Word ( Word8 )
44
import Data.Maybe( catMaybes, fromMaybe, isNothing )
45
46
import Language.Haskell.TH as TH hiding (sigP)
import Language.Haskell.TH.Syntax as TH
47
48

-------------------------------------------------------------------
49
--              The external interface
50

51
convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl RdrName]
52
convertToHsDecls loc ds = initCvt loc (fmap catMaybes (mapM cvt_dec ds))
53
54
  where
    cvt_dec d = wrapMsg "declaration" d (cvtDec d)
55

56
convertToHsExpr :: SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr RdrName)
57
convertToHsExpr loc e
58
  = initCvt loc $ wrapMsg "expression" e $ cvtl e
59

60
convertToPat :: SrcSpan -> TH.Pat -> Either MsgDoc (LPat RdrName)
61
62
convertToPat loc p
  = initCvt loc $ wrapMsg "pattern" p $ cvtPat p
63

64
convertToHsType :: SrcSpan -> TH.Type -> Either MsgDoc (LHsType RdrName)
65
66
convertToHsType loc t
  = initCvt loc $ wrapMsg "type" t $ cvtType t
67

68
-------------------------------------------------------------------
69
newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) }
70
71
        -- Push down the source location;
        -- Can fail, with a single error message
72

73
-- NB: If the conversion succeeds with (Right x), there should
74
75
--     be no exception values hiding in x
-- Reason: so a (head []) in TH code doesn't subsequently
76
--         make GHC crash when it tries to walk the generated tree
77

78
79
80
-- Use the loc everywhere, for lack of anything better
-- In particular, we want it on binding locations, so that variables bound in
-- the spliced-in declarations get a location that at least relates to the splice point
81

Austin Seipp's avatar
Austin Seipp committed
82
83
84
85
instance Functor CvtM where
    fmap = liftM

instance Applicative CvtM where
86
    pure x = CvtM $ \loc -> Right (loc,x)
Austin Seipp's avatar
Austin Seipp committed
87
88
    (<*>) = ap

89
90
instance Monad CvtM where
  (CvtM m) >>= k = CvtM $ \loc -> case m loc of
91
                                  Left err -> Left err
92
                                  Right (loc',v) -> unCvtM (k v) loc'
93

94
initCvt :: SrcSpan -> CvtM a -> Either MsgDoc a
95
initCvt loc (CvtM m) = fmap snd (m loc)
96

97
98
force :: a -> CvtM ()
force a = a `seq` return ()
99

100
failWith :: MsgDoc -> CvtM a
101
failWith m = CvtM (\_ -> Left m)
102

103
getL :: CvtM SrcSpan
104
105
106
107
getL = CvtM (\loc -> Right (loc,loc))

setL :: SrcSpan -> CvtM ()
setL loc = CvtM (\_ -> Right (loc, ()))
108

109
returnL :: a -> CvtM (Located a)
110
111
112
113
returnL x = CvtM (\loc -> Right (loc, L loc x))

returnJustL :: a -> CvtM (Maybe (Located a))
returnJustL = fmap Just . returnL
114

115
wrapParL :: (Located a -> a) -> a -> CvtM a
116
wrapParL add_par x = CvtM (\loc -> Right (loc, add_par (L loc x)))
117

118
119
120
121
122
123
124
wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b
-- E.g  wrapMsg "declaration" dec thing
wrapMsg what item (CvtM m)
  = CvtM (\loc -> case m loc of
                     Left err -> Left (err $$ getPprStyle msg)
                     Right v  -> Right v)
  where
125
126
        -- Show the item in pretty syntax normally,
        -- but with all its constructors if you say -dppr-debug
127
    msg sty = hang (text "When splicing a TH" <+> text what <> colon)
128
                 2 (if debugStyle sty
129
130
131
                    then text (show item)
                    else text (pprint item))

132
133
wrapL :: CvtM a -> CvtM (Located a)
wrapL (CvtM m) = CvtM (\loc -> case m loc of
134
                               Left err -> Left err
135
                               Right (loc',v) -> Right (loc',L loc v))
136
137

-------------------------------------------------------------------
138
139
140
141
cvtDecs :: [TH.Dec] -> CvtM [LHsDecl RdrName]
cvtDecs = fmap catMaybes . mapM cvtDec

cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl RdrName))
142
cvtDec (TH.ValD pat body ds)
143
  | TH.VarP s <- pat
144
145
  = do  { s' <- vNameL s
        ; cl' <- cvtClause (Clause [] body ds)
146
        ; returnJustL $ Hs.ValD $ mkFunBind s' [cl'] }
147

148
  | otherwise
149
150
  = do  { pat' <- cvtPat pat
        ; body' <- cvtGuard body
151
        ; ds' <- cvtLocalDecs (text "a where clause") ds
152
        ; returnJustL $ Hs.ValD $
153
          PatBind { pat_lhs = pat', pat_rhs = GRHSs body' (noLoc ds')
154
                  , pat_rhs_ty = placeHolderType, bind_fvs = placeHolderNames
155
                  , pat_ticks = ([],[]) } }
156

157
cvtDec (TH.FunD nm cls)
158
  | null cls
159
  = failWith (text "Function binding for"
160
                 <+> quotes (text (TH.pprint nm))
161
                 <+> text "has no equations")
162
  | otherwise
163
164
  = do  { nm' <- vNameL nm
        ; cls' <- mapM cvtClause cls
165
        ; returnJustL $ Hs.ValD $ mkFunBind nm' cls' }
166

167
cvtDec (TH.SigD nm typ)
168
  = do  { nm' <- vNameL nm
169
        ; ty' <- cvtType typ
170
        ; returnJustL $ Hs.SigD (TypeSig [nm'] (mkLHsSigWcType ty')) }
171

172
cvtDec (TH.InfixD fx nm)
173
  -- Fixity signatures are allowed for variables, constructors, and types
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
174
175
176
177
  -- the renamer automatically looks for types during renaming, even when
  -- the RdrName says it's a variable or a constructor. So, just assume
  -- it's a variable or constructor and proceed.
  = do { nm' <- vcNameL nm
178
       ; returnJustL (Hs.SigD (FixSig (FixitySig [nm'] (cvtFixity fx)))) }
179

180
cvtDec (PragmaD prag)
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
181
  = cvtPragmaD prag
182
183

cvtDec (TySynD tc tvs rhs)
184
185
  = do  { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
        ; rhs' <- cvtType rhs
186
187
188
189
        ; returnJustL $ TyClD $
          SynDecl { tcdLName = tc'
                  , tcdTyVars = tvs', tcdFVs = placeHolderNames
                  , tcdRhs = rhs' } }
190

191
cvtDec (DataD ctxt tc tvs ksig constrs derivs)
192
193
194
195
  = do  { let isGadtCon (GadtC    _ _ _) = True
              isGadtCon (RecGadtC _ _ _) = True
              isGadtCon (ForallC  _ _ c) = isGadtCon c
              isGadtCon _                = False
196
197
198
199
200
201
202
203
204
              isGadtDecl  = all isGadtCon constrs
              isH98Decl   = all (not . isGadtCon) constrs
        ; unless (isGadtDecl || isH98Decl)
                 (failWith (text "Cannot mix GADT constructors with Haskell 98"
                        <+> text "constructors"))
        ; unless (isNothing ksig || isGadtDecl)
                 (failWith (text "Kind signatures are only allowed on GADTs"))
        ; (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
        ; ksig' <- cvtKind `traverse` ksig
205
206
        ; cons' <- mapM cvtConstr constrs
        ; derivs' <- cvtDerivs derivs
207
208
        ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
                                , dd_ctxt = ctxt'
209
                                , dd_kindSig = ksig'
210
                                , dd_cons = cons', dd_derivs = derivs' }
211
212
        ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
                                        , tcdDataDefn = defn
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
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
220
        ; con' <- cvtConstr constr
        ; derivs' <- cvtDerivs derivs
221
222
        ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
                                , dd_ctxt = ctxt'
223
                                , dd_kindSig = ksig'
224
225
                                , dd_cons = [con']
                                , dd_derivs = derivs' }
226
        ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
227
                                    , tcdDataDefn = defn
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
228
                                    , tcdDataCusk = PlaceHolder
229
                                    , tcdFVs = placeHolderNames }) }
230

231
cvtDec (ClassD ctxt cl tvs fds decs)
232
233
  = do  { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
        ; fds'  <- mapM cvt_fundep fds
234
        ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs (text "a class declaration") decs
235
        ; unless (null adts')
236
237
            (failWith $ (text "Default data instance declarations"
                     <+> text "are not allowed:")
238
                   $$ (Outputable.ppr adts'))
239
        ; at_defs <- mapM cvt_at_def ats'
240
        ; returnJustL $ TyClD $
241
          ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
242
243
                    , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'
                    , tcdMeths = binds'
244
                    , tcdATs = fams', tcdATDefs = at_defs, tcdDocs = []
245
                    , tcdFVs = placeHolderNames }
246
                              -- no docs in TH ^^
247
        }
248
249
250
251
252
253
  where
    cvt_at_def :: LTyFamInstDecl RdrName -> CvtM (LTyFamDefltEqn RdrName)
    -- Very similar to what happens in RdrHsSyn.mkClassDecl
    cvt_at_def decl = case RdrHsSyn.mkATDefault decl of
                        Right def     -> return def
                        Left (_, msg) -> failWith msg
254

255
cvtDec (InstanceD o ctxt ty decs)
256
  = do  { let doc = text "an instance declaration"
257
        ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs
258
259
260
        ; unless (null fams') (failWith (mkBadDecMsg doc fams'))
        ; ctxt' <- cvtContext ctxt
        ; L loc ty' <- cvtType ty
261
        ; let inst_ty' = L loc $ HsQualTy { hst_ctxt = ctxt', hst_body = L loc ty' }
262
        ; returnJustL $ InstD $ ClsInstD $
263
264
265
266
          ClsInstDecl { cid_poly_ty = mkLHsSigType inst_ty'
                      , cid_binds = binds'
                      , cid_sigs = Hs.mkClassOpSigs sigs'
                      , cid_tyfam_insts = ats', cid_datafam_insts = adts'
267
268
269
270
271
272
273
274
275
276
277
                      , cid_overlap_mode = fmap (L loc . overlap) o } }
  where
  overlap pragma =
    case pragma of
      TH.Overlaps      -> Hs.Overlaps     "OVERLAPS"
      TH.Overlappable  -> Hs.Overlappable "OVERLAPPABLE"
      TH.Overlapping   -> Hs.Overlapping  "OVERLAPPING"
      TH.Incoherent    -> Hs.Incoherent   "INCOHERENT"



278

279
cvtDec (ForeignD ford)
280
  = do { ford' <- cvtForD ford
281
       ; returnJustL $ ForD ford' }
282

Jan Stolarek's avatar
Jan Stolarek committed
283
cvtDec (DataFamilyD tc tvs kind)
284
  = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
Jan Stolarek's avatar
Jan Stolarek committed
285
       ; result <- cvtMaybeKindToFamilyResultSig kind
286
       ; returnJustL $ TyClD $ FamDecl $
Jan Stolarek's avatar
Jan Stolarek committed
287
         FamilyDecl DataFamily tc' tvs' result Nothing }
288

289
cvtDec (DataInstD ctxt tc tys ksig constrs derivs)
290
  = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
291
       ; ksig' <- cvtKind `traverse` ksig
292
293
       ; cons' <- mapM cvtConstr constrs
       ; derivs' <- cvtDerivs derivs
294
295
       ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
                               , dd_ctxt = ctxt'
296
                               , dd_kindSig = ksig'
297
                               , dd_cons = cons', dd_derivs = derivs' }
298

299
       ; returnJustL $ InstD $ DataFamInstD
300
           { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
301
302
                                         , dfid_defn = defn
                                         , dfid_fvs = placeHolderNames } }}
303

304
cvtDec (NewtypeInstD ctxt tc tys ksig constr derivs)
305
  = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
306
       ; ksig' <- cvtKind `traverse` ksig
307
308
       ; con' <- cvtConstr constr
       ; derivs' <- cvtDerivs derivs
309
310
       ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
                               , dd_ctxt = ctxt'
311
                               , dd_kindSig = ksig'
312
                               , dd_cons = [con'], dd_derivs = derivs' }
313
       ; returnJustL $ InstD $ DataFamInstD
314
           { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
315
316
                                         , dfid_defn = defn
                                         , dfid_fvs = placeHolderNames } }}
317

318
cvtDec (TySynInstD tc eqn)
319
  = do  { tc' <- tconNameL tc
320
        ; eqn' <- cvtTySynEqn tc' eqn
321
        ; returnJustL $ InstD $ TyFamInstD
322
            { tfid_inst = TyFamInstDecl { tfid_eqn = eqn'
323
                                        , tfid_fvs = placeHolderNames } } }
324

325
326
cvtDec (OpenTypeFamilyD head)
  = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
Jan Stolarek's avatar
Jan Stolarek committed
327
       ; returnJustL $ TyClD $ FamDecl $
328
         FamilyDecl OpenTypeFamily tc' tyvars' result' injectivity' }
Jan Stolarek's avatar
Jan Stolarek committed
329

330
331
cvtDec (ClosedTypeFamilyD head eqns)
  = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
332
       ; eqns' <- mapM (cvtTySynEqn tc') eqns
333
       ; returnJustL $ TyClD $ FamDecl $
334
         FamilyDecl (ClosedTypeFamily (Just eqns')) tc' tyvars' result'
Jan Stolarek's avatar
Jan Stolarek committed
335
                                      injectivity' }
336
337
338
339

cvtDec (TH.RoleAnnotD tc roles)
  = do { tc' <- tconNameL tc
       ; let roles' = map (noLoc . cvtRole) roles
340
       ; returnJustL $ Hs.RoleAnnotD (RoleAnnotDecl tc' roles') }
341
342
343
344

cvtDec (TH.StandaloneDerivD cxt ty)
  = do { cxt' <- cvtContext cxt
       ; L loc ty'  <- cvtType ty
345
       ; let inst_ty' = L loc $ HsQualTy { hst_ctxt = cxt', hst_body = L loc ty' }
346
       ; returnJustL $ DerivD $
347
         DerivDecl { deriv_type = mkLHsSigType inst_ty', deriv_overlap_mode = Nothing } }
348
349
350
351

cvtDec (TH.DefaultSigD nm typ)
  = do { nm' <- vNameL nm
       ; ty' <- cvtType typ
352
       ; returnJustL $ Hs.SigD $ ClassOpSig True [nm'] (mkLHsSigType ty') }
353
354
355
356
----------------
cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName)
cvtTySynEqn tc (TySynEqn lhs rhs)
  = do  { lhs' <- mapM cvtType lhs
357
        ; rhs' <- cvtType rhs
358
        ; returnL $ TyFamEqn { tfe_tycon = tc
359
                             , tfe_pats = mkHsImplicitBndrs lhs'
360
                             , tfe_rhs = rhs' } }
361

362
----------------
363
cvt_ci_decs :: MsgDoc -> [TH.Dec]
364
365
            -> CvtM (LHsBinds RdrName,
                     [LSig RdrName],
366
367
368
                     [LFamilyDecl RdrName],
                     [LTyFamInstDecl RdrName],
                     [LDataFamInstDecl RdrName])
369
370
371
-- Convert the declarations inside a class or instance decl
-- ie signatures, bindings, and associated types
cvt_ci_decs doc decs
372
  = do  { decs' <- cvtDecs decs
373
374
375
        ; let (ats', bind_sig_decs') = partitionWith is_tyfam_inst decs'
        ; let (adts', no_ats')       = partitionWith is_datafam_inst bind_sig_decs'
        ; let (sigs', prob_binds')   = partitionWith is_sig no_ats'
376
        ; let (binds', prob_fams')   = partitionWith is_bind prob_binds'
377
        ; let (fams', bads)          = partitionWith is_fam_decl prob_fams'
378
        ; unless (null bads) (failWith (mkBadDecMsg doc bads))
Gergő Érdi's avatar
Gergő Érdi committed
379
380
          --We use FromSource as the origin of the bind
          -- because the TH declaration is user-written
381
        ; return (listToBag binds', sigs', fams', ats', adts') }
382
383

----------------
384
cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
385
386
             -> CvtM ( LHsContext RdrName
                     , Located RdrName
387
                     , LHsQTyVars RdrName)
388
cvt_tycl_hdr cxt tc tvs
389
390
391
  = do { cxt' <- cvtContext cxt
       ; tc'  <- tconNameL tc
       ; tvs' <- cvtTvs tvs
392
       ; return (cxt', tc', tvs')
393
394
395
396
397
       }

cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
               -> CvtM ( LHsContext RdrName
                       , Located RdrName
398
                       , HsImplicitBndrs RdrName [LHsType RdrName])
399
400
401
402
cvt_tyinst_hdr cxt tc tys
  = do { cxt' <- cvtContext cxt
       ; tc'  <- tconNameL tc
       ; tys' <- mapM cvtType tys
403
       ; return (cxt', tc', mkHsImplicitBndrs tys') }
404

405
406
407
408
409
410
411
412
413
414
415
416
417
----------------
cvt_tyfam_head :: TypeFamilyHead
               -> CvtM ( Located RdrName
                       , LHsQTyVars RdrName
                       , Hs.LFamilyResultSig RdrName
                       , Maybe (Hs.LInjectivityAnn RdrName))

cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity)
  = do {(_, tc', tyvars') <- cvt_tycl_hdr [] tc tyvars
       ; result' <- cvtFamilyResultSig result
       ; injectivity' <- traverse cvtInjectivityAnnotation injectivity
       ; return (tc', tyvars', result', injectivity') }

418
-------------------------------------------------------------------
419
--              Partitioning declarations
420
421
-------------------------------------------------------------------

422
423
is_fam_decl :: LHsDecl RdrName -> Either (LFamilyDecl RdrName) (LHsDecl RdrName)
is_fam_decl (L loc (TyClD (FamDecl { tcdFam = d }))) = Left (L loc d)
424
425
is_fam_decl decl = Right decl

426
427
428
429
430
431
432
is_tyfam_inst :: LHsDecl RdrName -> Either (LTyFamInstDecl RdrName) (LHsDecl RdrName)
is_tyfam_inst (L loc (Hs.InstD (TyFamInstD { tfid_inst = d }))) = Left (L loc d)
is_tyfam_inst decl                                              = Right decl

is_datafam_inst :: LHsDecl RdrName -> Either (LDataFamInstDecl RdrName) (LHsDecl RdrName)
is_datafam_inst (L loc (Hs.InstD (DataFamInstD { dfid_inst = d }))) = Left (L loc d)
is_datafam_inst decl                                                = Right decl
433
434
435
436
437
438
439

is_sig :: LHsDecl RdrName -> Either (LSig RdrName) (LHsDecl RdrName)
is_sig (L loc (Hs.SigD sig)) = Left (L loc sig)
is_sig decl                  = Right decl

is_bind :: LHsDecl RdrName -> Either (LHsBind RdrName) (LHsDecl RdrName)
is_bind (L loc (Hs.ValD bind)) = Left (L loc bind)
440
is_bind decl                   = Right decl
441

442
mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc
443
mkBadDecMsg doc bads
444
  = sep [ text "Illegal declaration(s) in" <+> doc <> colon
445
446
        , nest 2 (vcat (map Outputable.ppr bads)) ]

447
---------------------------------------------------
448
--      Data types
449
450
---------------------------------------------------

451
452
cvtConstr :: TH.Con -> CvtM (LConDecl RdrName)

453
cvtConstr (NormalC c strtys)
454
455
456
  = do  { c'   <- cNameL c
        ; cxt' <- returnL []
        ; tys' <- mapM cvt_arg strtys
Alan Zimmerman's avatar
Alan Zimmerman committed
457
        ; returnL $ mkConDeclH98 c' Nothing cxt' (PrefixCon tys') }
458
459

cvtConstr (RecC c varstrtys)
460
461
462
  = do  { c'    <- cNameL c
        ; cxt'  <- returnL []
        ; args' <- mapM cvt_id_arg varstrtys
Alan Zimmerman's avatar
Alan Zimmerman committed
463
        ; returnL $ mkConDeclH98 c' Nothing cxt'
Alan Zimmerman's avatar
Alan Zimmerman committed
464
                                   (RecCon (noLoc args')) }
465
466

cvtConstr (InfixC st1 c st2)
467
  = do  { c'   <- cNameL c
468
469
470
        ; cxt' <- returnL []
        ; st1' <- cvt_arg st1
        ; st2' <- cvt_arg st2
Alan Zimmerman's avatar
Alan Zimmerman committed
471
        ; returnL $ mkConDeclH98 c' Nothing cxt' (InfixCon st1' st2') }
472
473

cvtConstr (ForallC tvs ctxt con)
474
  = do  { tvs'        <- cvtTvs tvs
475
        ; L loc ctxt' <- cvtContext ctxt
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
        ; L _ con'    <- cvtConstr con
        ; returnL $ case con' of
                ConDeclGADT { con_type = conT } ->
                  con' { con_type =
                         HsIB PlaceHolder
                         (noLoc $ HsForAllTy (hsq_explicit tvs') $
                          (noLoc $ HsQualTy (L loc ctxt') (hsib_body conT))) }
                ConDeclH98  {} ->
                  let qvars = case (tvs, con_qvars con') of
                        ([], Nothing) -> Nothing
                        (_ , m_qvs  ) -> Just $
                          mkHsQTvs (hsQTvExplicit tvs' ++
                                    maybe [] hsQTvExplicit m_qvs)
                  in con' { con_qvars = qvars
                          , con_cxt = Just $
                            L loc (ctxt' ++
                                   unLoc (fromMaybe (noLoc [])
                                          (con_cxt con'))) } }

495
496
497
498
499
cvtConstr (GadtC c strtys ty)
  = do  { c'      <- mapM cNameL c
        ; args    <- mapM cvt_arg strtys
        ; L _ ty' <- cvtType ty
        ; c_ty    <- mk_arr_apps args ty'
500
501
        ; returnL $ mkGadtDecl c' (mkLHsSigType c_ty)}

502
cvtConstr (RecGadtC c varstrtys ty)
503
  = do  { c'       <- mapM cNameL c
504
        ; ty'      <- cvtType ty
505
        ; rec_flds <- mapM cvt_id_arg varstrtys
506
        ; let rec_ty = noLoc (HsFunTy (noLoc $ HsRecTy rec_flds) ty')
507
        ; returnL $ mkGadtDecl c' (mkLHsSigType rec_ty) }
508

509
510
511
512
513
514
515
516
517
518
519
520
cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness
cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack
cvtSrcUnpackedness SourceNoUnpack       = SrcNoUnpack
cvtSrcUnpackedness SourceUnpack         = SrcUnpack

cvtSrcStrictness :: TH.SourceStrictness -> SrcStrictness
cvtSrcStrictness NoSourceStrictness = NoSrcStrict
cvtSrcStrictness SourceLazy         = SrcLazy
cvtSrcStrictness SourceStrict       = SrcStrict

cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType RdrName)
cvt_arg (Bang su ss, ty)
Alan Zimmerman's avatar
Alan Zimmerman committed
521
  = do { ty' <- cvtType ty
522
523
524
       ; let su' = cvtSrcUnpackedness su
       ; let ss' = cvtSrcStrictness ss
       ; returnL $ HsBangTy (HsSrcBang Nothing su' ss') ty' }
525

526
cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField RdrName)
527
cvt_id_arg (i, str, ty)
528
  = do  { L li i' <- vNameL i
529
        ; ty' <- cvt_arg (str,ty)
530
531
532
533
534
        ; return $ noLoc (ConDeclField
                          { cd_fld_names
                              = [L li $ FieldOcc (L li i') PlaceHolder]
                          , cd_fld_type =  ty'
                          , cd_fld_doc = Nothing}) }
535

536
cvtDerivs :: TH.Cxt -> CvtM (HsDeriving RdrName)
537
cvtDerivs [] = return Nothing
538
539
540
541
cvtDerivs cs = fmap (Just . mkSigTypes) (cvtContext cs)
  where
    mkSigTypes :: Located (HsContext RdrName) -> Located [LHsSigType RdrName]
    mkSigTypes = fmap (map mkLHsSigType)
542

Alan Zimmerman's avatar
Alan Zimmerman committed
543
cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep (Located RdrName)))
544
545
546
cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs
                               ; ys' <- mapM tNameL ys
                               ; returnL (xs', ys') }
547
548
549


------------------------------------------
550
--      Foreign declarations
551
552
553
554
------------------------------------------

cvtForD :: Foreign -> CvtM (ForeignDecl RdrName)
cvtForD (ImportF callconv safety from nm ty)
555
556
557
558
559
560
561
  -- the prim and javascript calling conventions do not support headers
  -- and are inserted verbatim, analogous to mkImport in RdrHsSyn
  | callconv == TH.Prim || callconv == TH.JavaScript
  = mk_imp (CImport (noLoc (cvt_conv callconv)) (noLoc safety') Nothing
                    (CFunction (StaticTarget from (mkFastString from) Nothing
                                             True))
                    (noLoc from))
562
563
  | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety')
                                 (mkFastString (TH.nameBase nm))
Alan Zimmerman's avatar
Alan Zimmerman committed
564
                                 from (noLoc from)
565
  = mk_imp impspec
566
  | otherwise
567
  = failWith $ text (show from) <+> text "is not a valid ccall impent"
568
  where
569
570
571
    mk_imp impspec
      = do { nm' <- vNameL nm
           ; ty' <- cvtType ty
572
573
574
575
           ; return (ForeignImport { fd_name = nm'
                                   , fd_sig_ty = mkLHsSigType ty'
                                   , fd_co = noForeignImportCoercionYet
                                   , fd_fi = impspec })
576
           }
577
578
    safety' = case safety of
                     Unsafe     -> PlayRisky
Ian Lynagh's avatar
Ian Lynagh committed
579
                     Safe       -> PlaySafe
580
                     Interruptible -> PlayInterruptible
581
582

cvtForD (ExportF callconv as nm ty)
583
584
  = do  { nm' <- vNameL nm
        ; ty' <- cvtType ty
585
586
        ; let e = CExport (noLoc (CExportStatic as
                                                (mkFastString as)
587
                                                (cvt_conv callconv)))
Alan Zimmerman's avatar
Alan Zimmerman committed
588
                                                (noLoc as)
589
590
591
592
        ; return $ ForeignExport { fd_name = nm'
                                 , fd_sig_ty = mkLHsSigType ty'
                                 , fd_co = noForeignExportCoercionYet
                                 , fd_fe = e } }
593

594
cvt_conv :: TH.Callconv -> CCallConv
595
596
597
598
599
cvt_conv TH.CCall      = CCallConv
cvt_conv TH.StdCall    = StdCallConv
cvt_conv TH.CApi       = CApiConv
cvt_conv TH.Prim       = PrimCallConv
cvt_conv TH.JavaScript = JavaScriptCallConv
600

601
602
603
604
------------------------------------------
--              Pragmas
------------------------------------------

605
cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl RdrName))
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
606
607
608
cvtPragmaD (InlineP nm inline rm phases)
  = do { nm' <- vNameL nm
       ; let dflt = dfltActivation inline
Alan Zimmerman's avatar
Alan Zimmerman committed
609
610
       ; let ip   = InlinePragma { inl_src    = "{-# INLINE"
                                 , inl_inline = cvtInline inline
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
611
612
613
                                 , inl_rule   = cvtRuleMatch rm
                                 , inl_act    = cvtPhases phases dflt
                                 , inl_sat    = Nothing }
614
       ; returnJustL $ Hs.SigD $ InlineSig nm' ip }
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
615
616

cvtPragmaD (SpecialiseP nm ty inline phases)
617
618
  = do { nm' <- vNameL nm
       ; ty' <- cvtType ty
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
619
620
621
       ; let (inline', dflt) = case inline of
               Just inline1 -> (cvtInline inline1, dfltActivation inline1)
               Nothing      -> (EmptyInlineSpec,   AlwaysActive)
Alan Zimmerman's avatar
Alan Zimmerman committed
622
623
       ; let ip = InlinePragma { inl_src    = "{-# INLINE"
                               , inl_inline = inline'
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
624
625
626
                               , inl_rule   = Hs.FunLike
                               , inl_act    = cvtPhases phases dflt
                               , inl_sat    = Nothing }
627
       ; returnJustL $ Hs.SigD $ SpecSig nm' [mkLHsSigType ty'] ip }
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
628
629
630

cvtPragmaD (SpecialiseInstP ty)
  = do { ty' <- cvtType ty
631
632
       ; returnJustL $ Hs.SigD $
         SpecInstSig "{-# SPECIALISE" (mkLHsSigType ty') }
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
633
634
635
636
637
638
639

cvtPragmaD (RuleP nm bndrs lhs rhs phases)
  = do { let nm' = mkFastString nm
       ; let act = cvtPhases phases AlwaysActive
       ; bndrs' <- mapM cvtRuleBndr bndrs
       ; lhs'   <- cvtl lhs
       ; rhs'   <- cvtl rhs
Alan Zimmerman's avatar
Alan Zimmerman committed
640
       ; returnJustL $ Hs.RuleD
641
            $ HsRules "{-# RULES" [noLoc $ HsRule (noLoc (nm,nm')) act bndrs'
Alan Zimmerman's avatar
Alan Zimmerman committed
642
643
                                                  lhs' placeHolderNames
                                                  rhs' placeHolderNames]
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
644
       }
645

646
647
648
649
650
651
cvtPragmaD (AnnP target exp)
  = do { exp' <- cvtl exp
       ; target' <- case target of
         ModuleAnnotation  -> return ModuleAnnProvenance
         TypeAnnotation n  -> do
           n' <- tconName n
Alan Zimmerman's avatar
Alan Zimmerman committed
652
           return (TypeAnnProvenance  (noLoc n'))
653
         ValueAnnotation n -> do
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
654
           n' <- vcName n
Alan Zimmerman's avatar
Alan Zimmerman committed
655
656
           return (ValueAnnProvenance (noLoc n'))
       ; returnJustL $ Hs.AnnD $ HsAnnotation "{-# ANN" target' exp'
657
658
659
660
661
       }

cvtPragmaD (LineP line file)
  = do { setL (srcLocSpan (mkSrcLoc (fsLit file) line 1))
       ; return Nothing
662
663
       }

mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
dfltActivation :: TH.Inline -> Activation
dfltActivation TH.NoInline = NeverActive
dfltActivation _           = AlwaysActive

cvtInline :: TH.Inline -> Hs.InlineSpec
cvtInline TH.NoInline  = Hs.NoInline
cvtInline TH.Inline    = Hs.Inline
cvtInline TH.Inlinable = Hs.Inlinable

cvtRuleMatch :: TH.RuleMatch -> RuleMatchInfo
cvtRuleMatch TH.ConLike = Hs.ConLike
cvtRuleMatch TH.FunLike = Hs.FunLike

cvtPhases :: TH.Phases -> Activation -> Activation
cvtPhases AllPhases       dflt = dflt
679
680
cvtPhases (FromPhase i)   _    = ActiveAfter (show i) i
cvtPhases (BeforePhase i) _    = ActiveBefore (show i) i
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
681

682
cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr RdrName)
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
683
684
cvtRuleBndr (RuleVar n)
  = do { n' <- vNameL n
685
       ; return $ noLoc $ Hs.RuleBndr n' }
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
686
687
688
cvtRuleBndr (TypedRuleVar n ty)
  = do { n'  <- vNameL n
       ; ty' <- cvtType ty
689
       ; return $ noLoc $ Hs.RuleBndrSig n' $ mkLHsSigWcType ty' }
690

691
---------------------------------------------------
692
--              Declarations
693
---------------------------------------------------
694

695
cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds RdrName)
696
cvtLocalDecs doc ds
697
698
  | null ds
  = return EmptyLocalBinds
699
  | otherwise
700
  = do { ds' <- cvtDecs ds
701
702
703
       ; let (binds, prob_sigs) = partitionWith is_bind ds'
       ; let (sigs, bads) = partitionWith is_sig prob_sigs
       ; unless (null bads) (failWith (mkBadDecMsg doc bads))
704
       ; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) }
705

706
cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName))
707
cvtClause (Clause ps body wheres)
708
709
  = do  { ps' <- cvtPats ps
        ; g'  <- cvtGuard body
710
        ; ds' <- cvtLocalDecs (text "a where clause") wheres
711
712
        ; returnL $ Hs.Match NonFunBindMatch ps' Nothing
                             (GRHSs g' (noLoc ds')) }
713
714


715
-------------------------------------------------------------------
716
--              Expressions
717
-------------------------------------------------------------------
718

719
720
721
cvtl :: TH.Exp -> CvtM (LHsExpr RdrName)
cvtl e = wrapL (cvt e)
  where
722
723
    cvt (VarE s)        = do { s' <- vName s; return $ HsVar (noLoc s') }
    cvt (ConE s)        = do { s' <- cName s; return $ HsVar (noLoc s') }
724
    cvt (LitE l)
725
      | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }
726
      | otherwise       = do { l' <- cvtLit l;     return $ HsLit l' }
727
728
729
730
    cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y
                              ; return $ HsApp (mkLHsPar x') y' }
    cvt (AppE x y)            = do { x' <- cvtl x; y' <- cvtl y
                              ; return $ HsApp x' y' }
731
    cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e
732
                            ; return $ HsLam (mkMatchGroup FromSource [mkSimpleMatch ps' e']) }
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
733
    cvt (LamCaseE ms)  = do { ms' <- mapM cvtMatch ms
Simon Peyton Jones's avatar
Simon Peyton Jones committed
734
                            ; return $ HsLamCase (mkMatchGroup FromSource ms')
735
                            }
736
    cvt (TupE [e])     = do { e' <- cvtl e; return $ HsPar e' }
737
                                 -- Note [Dropping constructors]
738
                                 -- Singleton tuples treated like nothing (just parens)
739
740
741
742
743
744
    cvt (TupE es)      = do { es' <- mapM cvtl es
                            ; return $ ExplicitTuple (map (noLoc . Present) es')
                                                      Boxed }
    cvt (UnboxedTupE es)      = do { es' <- mapM cvtl es
                                   ; return $ ExplicitTuple
                                           (map (noLoc . Present) es') Unboxed }
745
    cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
746
                            ; return $ HsIf (Just noSyntaxExpr) x' y' z' }
747
    cvt (MultiIfE alts)
748
      | null alts      = failWith (text "Multi-way if-expression with no alternatives")
749
750
      | otherwise      = do { alts' <- mapM cvtpair alts
                            ; return $ HsMultiIf placeHolderType alts' }
751
    cvt (LetE ds e)    = do { ds' <- cvtLocalDecs (text "a let expression") ds
752
                            ; e' <- cvtl e; return $ HsLet (noLoc ds') e' }
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
753
    cvt (CaseE e ms)   = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
754
                            ; return $ HsCase e' (mkMatchGroup FromSource ms') }
755
756
    cvt (DoE ss)       = cvtHsDo DoExpr ss
    cvt (CompE ss)     = cvtHsDo ListComp ss
757
    cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr Nothing dd' }
758
    cvt (ListE xs)
759
      | Just s <- allCharLs xs       = do { l' <- cvtLit (StringL s); return (HsLit l') }
760
             -- Note [Converting strings]
761
762
763
      | otherwise       = do { xs' <- mapM cvtl xs
                             ; return $ ExplicitList placeHolderType Nothing xs'
                             }
764
765

    -- Infix expressions
766
    cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
767
                                          ; wrapParL HsPar $
768
                                            OpApp (mkLHsPar x') s' undefined (mkLHsPar y') }
769
770
771
772
                                            -- Parenthesise both arguments and result,
                                            -- to ensure this operator application does
                                            -- does not get re-associated
                            -- See Note [Operator association]
773
    cvt (InfixE Nothing  s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
774
775
                                          ; wrapParL HsPar $ SectionR s' y' }
                                            -- See Note [Sections in HsSyn] in HsExpr
776
    cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
777
                                          ; wrapParL HsPar $ SectionL x' s' }
778

779
780
781
    cvt (InfixE Nothing  s Nothing ) = do { s' <- cvtl s; return $ HsPar s' }
                                       -- Can I indicate this is an infix thing?
                                       -- Note [Dropping constructors]
782

783
    cvt (UInfixE x s y)  = do { x' <- cvtl x
784
                              ; let x'' = case x' of
785
786
787
                                            L _ (OpApp {}) -> x'
                                            _ -> mkLHsPar x'
                              ; cvtOpApp x'' s y } --  Note [Converting UInfix]
788

789
    cvt (ParensE e)      = do { e' <- cvtl e; return $ HsPar e' }
790
    cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtType t
791
                              ; return $ ExprWithTySig e' (mkLHsSigWcType t') }
792
    cvt (RecConE c flds) = do { c' <- cNameL c