Convert.hs 68.4 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

42
import Data.Maybe( catMaybes, fromMaybe, isNothing )
43
44
import Language.Haskell.TH as TH hiding (sigP)
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
52
  where
    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
60
convertToPat loc p
  = initCvt loc $ wrapMsg "pattern" p $ cvtPat p
61

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

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

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

76
77
78
-- 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
79

Austin Seipp's avatar
Austin Seipp committed
80
81
82
83
instance Functor CvtM where
    fmap = liftM

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

87
88
instance Monad CvtM where
  (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
96
force :: a -> CvtM ()
force a = a `seq` return ()
97

98
failWith :: MsgDoc -> CvtM a
99
failWith m = CvtM (\_ -> Left m)
100

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

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

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

returnJustL :: a -> CvtM (Maybe (Located a))
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
117
118
119
120
121
122
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
123
124
        -- Show the item in pretty syntax normally,
        -- 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
128
129
                    then text (show item)
                    else text (pprint item))

130
131
wrapL :: CvtM a -> CvtM (Located a)
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
137
138
139
cvtDecs :: [TH.Dec] -> CvtM [LHsDecl RdrName]
cvtDecs = fmap catMaybes . mapM cvtDec

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 (FunRhs s' Prefix) (Clause [] body ds)
144
        ; returnJustL $ Hs.ValD $ mkFunBind s' [cl'] }
145

146
  | otherwise
147
148
  = do  { pat' <- cvtPat pat
        ; 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 (FunRhs nm' Prefix)) 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
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
172
173
174
175
  -- 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
176
       ; returnJustL (Hs.SigD (FixSig (FixitySig [nm'] (cvtFixity fx)))) }
177

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

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

190
cvtDec (DataD ctxt tc tvs ksig constrs derivs)
191
192
193
194
  = do  { let isGadtCon (GadtC    _ _ _) = True
              isGadtCon (RecGadtC _ _ _) = True
              isGadtCon (ForallC  _ _ c) = isGadtCon c
              isGadtCon _                = False
195
196
197
198
199
200
201
202
203
              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
204
205
        ; cons' <- mapM cvtConstr constrs
        ; derivs' <- cvtDerivs derivs
206
207
        ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
                                , 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
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
                                    , tcdFixity = Prefix
228
                                    , tcdDataDefn = defn
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
229
                                    , tcdDataCusk = PlaceHolder
230
                                    , tcdFVs = placeHolderNames }) }
231

232
cvtDec (ClassD ctxt cl tvs fds decs)
233
234
  = do  { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
        ; fds'  <- mapM cvt_fundep fds
235
        ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs (text "a class declaration") decs
236
        ; unless (null adts')
237
238
            (failWith $ (text "Default data instance declarations"
                     <+> 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
245
                    , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'
                    , tcdMeths = binds'
246
                    , tcdATs = fams', tcdATDefs = at_defs, tcdDocs = []
247
                    , tcdFVs = placeHolderNames }
248
                              -- no docs in TH ^^
249
        }
250
251
252
253
254
255
  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
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
261
262
        ; unless (null fams') (failWith (mkBadDecMsg doc fams'))
        ; ctxt' <- cvtContext ctxt
        ; L loc ty' <- cvtType ty
263
        ; let inst_ty' = L loc $ HsQualTy { hst_ctxt = ctxt', hst_body = L loc ty' }
264
        ; returnJustL $ InstD $ ClsInstD $
265
266
267
268
          ClsInstDecl { cid_poly_ty = mkLHsSigType inst_ty'
                      , cid_binds = binds'
                      , cid_sigs = Hs.mkClassOpSigs sigs'
                      , cid_tyfam_insts = ats', cid_datafam_insts = adts'
269
270
271
272
                      , cid_overlap_mode = fmap (L loc . overlap) o } }
  where
  overlap pragma =
    case pragma of
Alan Zimmerman's avatar
Alan Zimmerman committed
273
274
275
276
      TH.Overlaps      -> Hs.Overlaps     (SourceText "OVERLAPS")
      TH.Overlappable  -> Hs.Overlappable (SourceText "OVERLAPPABLE")
      TH.Overlapping   -> Hs.Overlapping  (SourceText "OVERLAPPING")
      TH.Incoherent    -> Hs.Incoherent   (SourceText "INCOHERENT")
277
278
279



280

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

Jan Stolarek's avatar
Jan Stolarek committed
285
cvtDec (DataFamilyD tc tvs kind)
286
  = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
Jan Stolarek's avatar
Jan Stolarek committed
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
295
       ; cons' <- mapM cvtConstr constrs
       ; derivs' <- cvtDerivs derivs
296
297
       ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
                               , 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
311
       ; con' <- cvtConstr constr
       ; derivs' <- cvtDerivs derivs
312
313
       ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
                               , 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
330
cvtDec (OpenTypeFamilyD head)
  = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
Jan Stolarek's avatar
Jan Stolarek committed
331
       ; returnJustL $ TyClD $ FamDecl $
332
         FamilyDecl OpenTypeFamily tc' tyvars' Prefix result' injectivity' }
Jan Stolarek's avatar
Jan Stolarek committed
333

334
335
cvtDec (ClosedTypeFamilyD head eqns)
  = 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'
Jan Stolarek's avatar
Jan Stolarek committed
339
                                      injectivity' }
340
341
342
343

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

Ryan Scott's avatar
Ryan Scott committed
346
cvtDec (TH.StandaloneDerivD ds cxt ty)
347
348
  = do { cxt' <- cvtContext cxt
       ; L loc ty'  <- cvtType ty
349
       ; let inst_ty' = L loc $ HsQualTy { hst_ctxt = cxt', hst_body = L loc ty' }
350
       ; returnJustL $ DerivD $
Ryan Scott's avatar
Ryan Scott committed
351
352
353
         DerivDecl { deriv_strategy = fmap (L loc . cvtDerivStrategy) ds
                   , deriv_type = mkLHsSigType inst_ty'
                   , deriv_overlap_mode = Nothing } }
354
355
356
357

cvtDec (TH.DefaultSigD nm typ)
  = do { nm' <- vNameL nm
       ; ty' <- cvtType typ
358
       ; returnJustL $ Hs.SigD $ ClassOpSig True [nm'] (mkLHsSigType ty') }
359
360
361
362

cvtDec (TH.PatSynD nm args dir pat)
  = do { nm'   <- cNameL nm
       ; args' <- cvtArgs args
363
       ; dir'  <- cvtDir nm' dir
364
365
366
367
368
369
370
371
372
373
374
       ; pat'  <- cvtPat pat
       ; returnJustL $ Hs.ValD $ PatSynBind $
           PSB nm' placeHolderType args' pat' dir' }
  where
    cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixPatSyn <$> mapM vNameL args
    cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixPatSyn <$> vNameL a1 <*> vNameL a2
    cvtArgs (TH.RecordPatSyn sels)
      = do { sels' <- mapM vNameL sels
           ; vars' <- mapM (vNameL . mkNameS . nameBase) sels
           ; return $ Hs.RecordPatSyn $ zipWith RecordPatSynField sels' vars' }

375
376
377
378
    cvtDir _ Unidir          = return Unidirectional
    cvtDir _ ImplBidir       = return ImplicitBidirectional
    cvtDir n (ExplBidir cls) =
      do { ms <- mapM (cvtClause (FunRhs n Prefix)) cls
379
380
381
382
383
         ; return $ ExplicitBidirectional $ mkMatchGroup FromSource ms }

cvtDec (TH.PatSynSigD nm ty)
  = do { nm' <- cNameL nm
       ; ty' <- cvtPatSynSigTy ty
384
       ; returnJustL $ Hs.SigD $ PatSynSig [nm'] (mkLHsSigType ty') }
385

386
387
388
389
----------------
cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName)
cvtTySynEqn tc (TySynEqn lhs rhs)
  = do  { lhs' <- mapM 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
399
            -> CvtM (LHsBinds RdrName,
                     [LSig RdrName],
400
401
402
                     [LFamilyDecl RdrName],
                     [LTyFamInstDecl RdrName],
                     [LDataFamInstDecl RdrName])
403
404
405
-- Convert the declarations inside a class or instance decl
-- ie signatures, bindings, and associated types
cvt_ci_decs doc decs
406
  = do  { decs' <- cvtDecs decs
407
408
409
        ; 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'
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))
Gergő Érdi's avatar
Gergő Érdi committed
413
414
          --We use FromSource as the origin of the bind
          -- 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
420
             -> CvtM ( LHsContext RdrName
                     , Located RdrName
421
                     , LHsQTyVars RdrName)
422
cvt_tycl_hdr cxt tc tvs
423
424
425
  = do { cxt' <- cvtContext cxt
       ; tc'  <- tconNameL tc
       ; tvs' <- cvtTvs tvs
426
       ; return (cxt', tc', tvs')
427
428
429
430
431
       }

cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
               -> CvtM ( LHsContext RdrName
                       , Located RdrName
432
                       , HsImplicitBndrs RdrName [LHsType RdrName])
433
434
435
436
cvt_tyinst_hdr cxt tc tys
  = do { cxt' <- cvtContext cxt
       ; tc'  <- tconNameL tc
       ; tys' <- mapM cvtType tys
437
       ; return (cxt', tc', mkHsImplicitBndrs tys') }
438

439
440
441
442
443
444
445
446
447
448
449
450
451
----------------
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') }

452
-------------------------------------------------------------------
453
--              Partitioning declarations
454
455
-------------------------------------------------------------------

456
457
is_fam_decl :: LHsDecl RdrName -> Either (LFamilyDecl RdrName) (LHsDecl RdrName)
is_fam_decl (L loc (TyClD (FamDecl { tcdFam = d }))) = Left (L loc d)
458
459
is_fam_decl decl = Right decl

460
461
462
463
464
465
466
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
467
468
469
470
471
472
473

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)
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
480
        , nest 2 (vcat (map Outputable.ppr bads)) ]

481
---------------------------------------------------
482
--      Data types
483
484
---------------------------------------------------

485
486
cvtConstr :: TH.Con -> CvtM (LConDecl RdrName)

487
cvtConstr (NormalC c strtys)
488
489
490
  = do  { c'   <- cNameL c
        ; cxt' <- returnL []
        ; tys' <- mapM cvt_arg strtys
Alan Zimmerman's avatar
Alan Zimmerman committed
491
        ; returnL $ mkConDeclH98 c' Nothing cxt' (PrefixCon tys') }
492
493

cvtConstr (RecC c varstrtys)
494
495
496
  = do  { c'    <- cNameL c
        ; cxt'  <- returnL []
        ; args' <- mapM cvt_id_arg varstrtys
Alan Zimmerman's avatar
Alan Zimmerman committed
497
        ; returnL $ mkConDeclH98 c' Nothing cxt'
Alan Zimmerman's avatar
Alan Zimmerman committed
498
                                   (RecCon (noLoc args')) }
499
500

cvtConstr (InfixC st1 c st2)
501
  = do  { c'   <- cNameL c
502
503
504
        ; cxt' <- returnL []
        ; st1' <- cvt_arg st1
        ; st2' <- cvt_arg st2
Alan Zimmerman's avatar
Alan Zimmerman committed
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
511
512
        ; L _ con'    <- cvtConstr con
        ; returnL $ case con' of
                ConDeclGADT { con_type = conT } ->
513
514
515
516
517
518
519
520
521
522
523
                  let hs_ty
                        | null tvs = rho_ty
                        | otherwise = noLoc $ HsForAllTy
                                                { hst_bndrs = hsq_explicit tvs'
                                                , hst_body  = rho_ty }
                      rho_ty
                        | null ctxt = hsib_body conT
                        | otherwise = noLoc $ HsQualTy
                                                { hst_ctxt = L loc ctxt'
                                                , hst_body = hsib_body conT }
                  in con' { con_type = HsIB PlaceHolder hs_ty }
524
525
526
527
528
529
530
531
532
533
534
535
                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'))) } }

536
537
538
539
540
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'
541
542
        ; returnL $ mkGadtDecl c' (mkLHsSigType c_ty)}

543
cvtConstr (RecGadtC c varstrtys ty)
544
  = do  { c'       <- mapM cNameL c
545
        ; ty'      <- cvtType ty
546
        ; rec_flds <- mapM cvt_id_arg varstrtys
547
        ; let rec_ty = noLoc (HsFunTy (noLoc $ HsRecTy rec_flds) ty')
548
        ; returnL $ mkGadtDecl c' (mkLHsSigType rec_ty) }
549

550
551
552
553
554
555
556
557
558
559
560
561
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
562
  = do { ty' <- cvtType ty
563
564
       ; let su' = cvtSrcUnpackedness su
       ; let ss' = cvtSrcStrictness ss
Alan Zimmerman's avatar
Alan Zimmerman committed
565
       ; returnL $ HsBangTy (HsSrcBang NoSourceText su' ss') ty' }
566

567
cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField RdrName)
568
cvt_id_arg (i, str, ty)
569
  = do  { L li i' <- vNameL i
570
        ; ty' <- cvt_arg (str,ty)
571
572
573
574
575
        ; return $ noLoc (ConDeclField
                          { cd_fld_names
                              = [L li $ FieldOcc (L li i') PlaceHolder]
                          , cd_fld_type =  ty'
                          , cd_fld_doc = Nothing}) }
576

Ryan Scott's avatar
Ryan Scott committed
577
578
579
cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving RdrName)
cvtDerivs cs = do { cs' <- mapM cvtDerivClause cs
                  ; returnL cs' }
580

Alan Zimmerman's avatar
Alan Zimmerman committed
581
cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep (Located RdrName)))
582
583
584
cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs
                               ; ys' <- mapM tNameL ys
                               ; returnL (xs', ys') }
585
586
587


------------------------------------------
588
--      Foreign declarations
589
590
591
592
------------------------------------------

cvtForD :: Foreign -> CvtM (ForeignDecl RdrName)
cvtForD (ImportF callconv safety from nm ty)
593
594
595
596
  -- 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
Alan Zimmerman's avatar
Alan Zimmerman committed
597
598
                    (CFunction (StaticTarget (SourceText from)
                                             (mkFastString from) Nothing
599
                                             True))
Alan Zimmerman's avatar
Alan Zimmerman committed
600
                    (noLoc $ quotedSourceText from))
601
602
  | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety')
                                 (mkFastString (TH.nameBase nm))
Alan Zimmerman's avatar
Alan Zimmerman committed
603
                                 from (noLoc $ quotedSourceText from)
604
  = mk_imp impspec
605
  | otherwise
606
  = failWith $ text (show from) <+> text "is not a valid ccall impent"
607
  where
608
609
610
    mk_imp impspec
      = do { nm' <- vNameL nm
           ; ty' <- cvtType ty
611
612
613
614
           ; return (ForeignImport { fd_name = nm'
                                   , fd_sig_ty = mkLHsSigType ty'
                                   , fd_co = noForeignImportCoercionYet
                                   , fd_fi = impspec })
615
           }
616
617
    safety' = case safety of
                     Unsafe     -> PlayRisky
Ian Lynagh's avatar
Ian Lynagh committed
618
                     Safe       -> PlaySafe
619
                     Interruptible -> PlayInterruptible
620
621

cvtForD (ExportF callconv as nm ty)
622
623
  = do  { nm' <- vNameL nm
        ; ty' <- cvtType ty
Alan Zimmerman's avatar
Alan Zimmerman committed
624
        ; let e = CExport (noLoc (CExportStatic (SourceText as)
625
                                                (mkFastString as)
626
                                                (cvt_conv callconv)))
Alan Zimmerman's avatar
Alan Zimmerman committed
627
                                                (noLoc (SourceText as))
628
629
630
631
        ; return $ ForeignExport { fd_name = nm'
                                 , fd_sig_ty = mkLHsSigType ty'
                                 , fd_co = noForeignExportCoercionYet
                                 , fd_fe = e } }
632

633
cvt_conv :: TH.Callconv -> CCallConv
634
635
636
637
638
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
639

640
641
642
643
------------------------------------------
--              Pragmas
------------------------------------------

644
cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl RdrName))
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
645
646
647
cvtPragmaD (InlineP nm inline rm phases)
  = do { nm' <- vNameL nm
       ; let dflt = dfltActivation inline
Alan Zimmerman's avatar
Alan Zimmerman committed
648
649
650
651
       ; let src TH.NoInline  = "{-# NOINLINE"
             src TH.Inline    = "{-# INLINE"
             src TH.Inlinable = "{-# INLINABLE"
       ; let ip   = InlinePragma { inl_src    = SourceText $ src inline
Alan Zimmerman's avatar
Alan Zimmerman committed
652
                                 , inl_inline = cvtInline inline
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
653
654
655
                                 , inl_rule   = cvtRuleMatch rm
                                 , inl_act    = cvtPhases phases dflt
                                 , inl_sat    = Nothing }
656
       ; returnJustL $ Hs.SigD $ InlineSig nm' ip }
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
657
658

cvtPragmaD (SpecialiseP nm ty inline phases)
659
660
  = do { nm' <- vNameL nm
       ; ty' <- cvtType ty
Alan Zimmerman's avatar
Alan Zimmerman committed
661
662
663
664
665
666
667
668
669
       ; let src TH.NoInline  = "{-# SPECIALISE NOINLINE"
             src TH.Inline    = "{-# SPECIALISE INLINE"
             src TH.Inlinable = "{-# SPECIALISE INLINE"
       ; let (inline', dflt,srcText) = case inline of
               Just inline1 -> (cvtInline inline1, dfltActivation inline1,
                                src inline1)
               Nothing      -> (EmptyInlineSpec,   AlwaysActive,
                                "{-# SPECIALISE")
       ; let ip = InlinePragma { inl_src    = SourceText srcText
Alan Zimmerman's avatar
Alan Zimmerman committed
670
                               , inl_inline = inline'
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
671
672
673
                               , inl_rule   = Hs.FunLike
                               , inl_act    = cvtPhases phases dflt
                               , inl_sat    = Nothing }
674
       ; returnJustL $ Hs.SigD $ SpecSig nm' [mkLHsSigType ty'] ip }
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
675
676
677

cvtPragmaD (SpecialiseInstP ty)
  = do { ty' <- cvtType ty
678
       ; returnJustL $ Hs.SigD $
Alan Zimmerman's avatar
Alan Zimmerman committed
679
         SpecInstSig (SourceText "{-# SPECIALISE") (mkLHsSigType ty') }
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
680
681
682
683
684
685
686

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
687
       ; returnJustL $ Hs.RuleD
Alan Zimmerman's avatar
Alan Zimmerman committed
688
689
            $ HsRules (SourceText "{-# RULES")
                      [noLoc $ HsRule (noLoc (SourceText nm,nm')) act bndrs'
Alan Zimmerman's avatar
Alan Zimmerman committed
690
691
                                                  lhs' placeHolderNames
                                                  rhs' placeHolderNames]
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
692
       }
693

694
695
696
697
698
699
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
700
           return (TypeAnnProvenance  (noLoc n'))
701
         ValueAnnotation n -> do
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
702
           n' <- vcName n
Alan Zimmerman's avatar
Alan Zimmerman committed
703
           return (ValueAnnProvenance (noLoc n'))
Alan Zimmerman's avatar
Alan Zimmerman committed
704
705
       ; returnJustL $ Hs.AnnD $ HsAnnotation (SourceText "{-# ANN") target'
                                               exp'
706
707
708
709
710
       }

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

mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
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
Alan Zimmerman's avatar
Alan Zimmerman committed
728
729
cvtPhases (FromPhase i)   _    = ActiveAfter NoSourceText i
cvtPhases (BeforePhase i) _    = ActiveBefore NoSourceText i
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
730

731
cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr RdrName)
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
732
733
cvtRuleBndr (RuleVar n)
  = do { n' <- vNameL n
734
       ; return $ noLoc $ Hs.RuleBndr n' }
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
735
736
737
cvtRuleBndr (TypedRuleVar n ty)
  = do { n'  <- vNameL n
       ; ty' <- cvtType ty
738
       ; return $ noLoc $ Hs.RuleBndrSig n' $ mkLHsSigWcType ty' }
739

740
---------------------------------------------------
741
--              Declarations
742
---------------------------------------------------
743

744
cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds RdrName)
745
cvtLocalDecs doc ds
746
747
  | null ds
  = return EmptyLocalBinds
748
  | otherwise
749
  = do { ds' <- cvtDecs ds
750
751
752
       ; let (binds, prob_sigs) = partitionWith is_bind ds'
       ; let (sigs, bads) = partitionWith is_sig prob_sigs
       ; unless (null bads) (failWith (mkBadDecMsg doc bads))
753
       ; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) }
754

755
756
757
cvtClause :: HsMatchContext RdrName
          -> TH.Clause -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName))
cvtClause ctxt (Clause ps body wheres)
758
759
  = do  { ps' <- cvtPats ps
        ; g'  <- cvtGuard body
760
        ; ds' <- cvtLocalDecs (text "a where clause") wheres
761
        ; returnL $ Hs.Match ctxt ps' Nothing
762
                             (GRHSs g' (noLoc ds')) }
763
764


765
-------------------------------------------------------------------
766
--              Expressions
767
-------------------------------------------------------------------
768

769
770
771
cvtl :: TH.Exp -> CvtM (LHsExpr RdrName)
cvtl e = wrapL (cvt e)
  where
772
773
    cvt (VarE s)        = do { s' <- vName s; return $ HsVar (noLoc s') }
    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') y' }
779
    cvt (AppE x y)            = do { x' <- cvtl x; y' <- cvtl y
780
                                   ; return $ HsApp x' y' }
781
782
783
    cvt (AppTypeE e t) = do { e' <- cvtl e
                            ; t' <- cvtType t
                            ; return $ HsAppType e' $ mkHsWildCardBndrs t' }
784
    cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e
785
786
787
                            ; return $ HsLam (mkMatchGroup FromSource
                                             [mkSimpleMatch LambdaExpr ps' e'])}
    cvt (LamCaseE ms)  = do { ms' <- mapM (cvtMatch LambdaExpr) ms
Simon Peyton Jones's avatar
Simon Peyton Jones committed
788
                            ; return $ HsLamCase (mkMatchGroup FromSource ms')
789
                            }
790
    cvt (TupE [e])     = do { e' <- cvtl e; return $ HsPar e' }
791
                                 -- Note [Dropping constructors]
792
                                 -- Singleton tuples treated like nothing (just parens)
793
794
795
796
797
798
    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 }
799
800
801
802
    cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e
                                       ; unboxedSumChecks alt arity
                                       ; return $ ExplicitSum
                                             alt arity e' placeHolderType }