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

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

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

import HsSyn as Hs
17
18
19
20
21
import qualified Class
import RdrName
import qualified Name
import Module
import RdrHsSyn
22
import qualified OccName
23
24
25
import OccName
import SrcLoc
import Type
26
import qualified Coercion ( Role(..) )
27
import TysWiredIn
28
import TysPrim (eqPrimTyCon)
29
import BasicTypes as Hs
30
31
32
33
import ForeignCall
import Unique
import ErrUtils
import Bag
34
import Lexeme
35
import Util
36
import FastString
37
import Outputable
38
import MonadUtils ( foldrM )
39

40
import qualified Data.ByteString as BS
41
import Control.Monad( unless, liftM, ap, (<=<) )
42

43
import Data.Maybe( catMaybes, fromMaybe, isNothing )
44
45
import Language.Haskell.TH as TH hiding (sigP)
import Language.Haskell.TH.Syntax as TH
46
47

-------------------------------------------------------------------
48
--              The external interface
49

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

117
118
119
120
121
122
123
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
124
125
        -- Show the item in pretty syntax normally,
        -- but with all its constructors if you say -dppr-debug
126
    msg sty = hang (text "When splicing a TH" <+> text what <> colon)
127
                 2 (if debugStyle sty
128
129
130
                    then text (show item)
                    else text (pprint item))

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

-------------------------------------------------------------------
137
cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs]
138
139
cvtDecs = fmap catMaybes . mapM cvtDec

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

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

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

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

171
cvtDec (TH.InfixD fx nm)
172
  -- Fixity signatures are allowed for variables, constructors, and types
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
173
174
175
176
  -- 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
177
       ; returnJustL (Hs.SigD (FixSig (FixitySig [nm'] (cvtFixity fx)))) }
178

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

cvtDec (TySynD tc tvs rhs)
183
184
  = do  { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
        ; rhs' <- cvtType rhs
185
        ; returnJustL $ TyClD $
186
187
188
          SynDecl { tcdLName = tc', tcdTyVars = tvs'
                  , tcdFixity = Prefix
                  , tcdFVs = placeHolderNames
189
                  , 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
        ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
212
                                        , tcdFixity = Prefix
213
                                        , tcdDataDefn = defn
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
214
                                        , tcdDataCusk = PlaceHolder
215
                                        , tcdFVs = placeHolderNames }) }
216

217
cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)
218
  = do  { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
219
        ; ksig' <- cvtKind `traverse` ksig
220
221
        ; con' <- cvtConstr constr
        ; derivs' <- cvtDerivs derivs
222
223
        ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
                                , dd_ctxt = ctxt'
224
                                , dd_kindSig = ksig'
225
226
                                , dd_cons = [con']
                                , dd_derivs = derivs' }
227
        ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
228
                                    , tcdFixity = Prefix
229
                                    , tcdDataDefn = defn
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
230
                                    , tcdDataCusk = PlaceHolder
231
                                    , tcdFVs = placeHolderNames }) }
232

233
cvtDec (ClassD ctxt cl tvs fds decs)
234
235
  = do  { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
        ; fds'  <- mapM cvt_fundep fds
236
        ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs (text "a class declaration") decs
237
        ; unless (null adts')
238
239
            (failWith $ (text "Default data instance declarations"
                     <+> text "are not allowed:")
240
                   $$ (Outputable.ppr adts'))
241
        ; at_defs <- mapM cvt_at_def ats'
242
        ; returnJustL $ TyClD $
243
          ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
244
                    , tcdFixity = Prefix
245
246
                    , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'
                    , tcdMeths = binds'
247
                    , tcdATs = fams', tcdATDefs = at_defs, tcdDocs = []
248
                    , tcdFVs = placeHolderNames }
249
                              -- no docs in TH ^^
250
        }
251
  where
252
    cvt_at_def :: LTyFamInstDecl GhcPs -> CvtM (LTyFamDefltEqn GhcPs)
253
254
255
256
    -- 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
257

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



281

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

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

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

302
       ; returnJustL $ InstD $ DataFamInstD
303
           { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
304
                                         , dfid_defn = defn
305
                                         , dfid_fixity = Prefix
306
                                         , dfid_fvs = placeHolderNames } }}
307

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

323
cvtDec (TySynInstD tc eqn)
324
  = do  { tc' <- tconNameL tc
325
        ; eqn' <- cvtTySynEqn tc' eqn
326
        ; returnJustL $ InstD $ TyFamInstD
327
            { tfid_inst = TyFamInstDecl { tfid_eqn = eqn'
328
                                        , tfid_fvs = placeHolderNames } } }
329

330
331
cvtDec (OpenTypeFamilyD head)
  = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
Jan Stolarek's avatar
Jan Stolarek committed
332
       ; returnJustL $ TyClD $ FamDecl $
333
         FamilyDecl OpenTypeFamily tc' tyvars' Prefix result' injectivity' }
Jan Stolarek's avatar
Jan Stolarek committed
334

335
336
cvtDec (ClosedTypeFamilyD head eqns)
  = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
337
       ; eqns' <- mapM (cvtTySynEqn tc') eqns
338
       ; returnJustL $ TyClD $ FamDecl $
339
         FamilyDecl (ClosedTypeFamily (Just eqns')) tc' tyvars' Prefix result'
Jan Stolarek's avatar
Jan Stolarek committed
340
                                      injectivity' }
341
342
343
344

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

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

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

cvtDec (TH.PatSynD nm args dir pat)
  = do { nm'   <- cNameL nm
       ; args' <- cvtArgs args
364
       ; dir'  <- cvtDir nm' dir
365
366
367
368
369
370
371
372
373
374
375
       ; 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' }

376
377
378
    cvtDir _ Unidir          = return Unidirectional
    cvtDir _ ImplBidir       = return ImplicitBidirectional
    cvtDir n (ExplBidir cls) =
Ben Gamari's avatar
Ben Gamari committed
379
      do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls
380
381
382
383
384
         ; return $ ExplicitBidirectional $ mkMatchGroup FromSource ms }

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

387
----------------
388
cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
389
cvtTySynEqn tc (TySynEqn lhs rhs)
390
  = do  { lhs' <- mapM (wrap_apps <=< cvtType) lhs
391
        ; rhs' <- cvtType rhs
392
        ; returnL $ TyFamEqn { tfe_tycon = tc
393
                             , tfe_pats = mkHsImplicitBndrs lhs'
394
                             , tfe_fixity = Prefix
395
                             , tfe_rhs = rhs' } }
396

397
----------------
398
cvt_ci_decs :: MsgDoc -> [TH.Dec]
399
400
401
402
403
            -> CvtM (LHsBinds GhcPs,
                     [LSig GhcPs],
                     [LFamilyDecl GhcPs],
                     [LTyFamInstDecl GhcPs],
                     [LDataFamInstDecl GhcPs])
404
405
406
-- Convert the declarations inside a class or instance decl
-- ie signatures, bindings, and associated types
cvt_ci_decs doc decs
407
  = do  { decs' <- cvtDecs decs
408
409
410
        ; 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'
411
        ; let (binds', prob_fams')   = partitionWith is_bind prob_binds'
412
        ; let (fams', bads)          = partitionWith is_fam_decl prob_fams'
413
        ; unless (null bads) (failWith (mkBadDecMsg doc bads))
Gergő Érdi's avatar
Gergő Érdi committed
414
415
          --We use FromSource as the origin of the bind
          -- because the TH declaration is user-written
416
        ; return (listToBag binds', sigs', fams', ats', adts') }
417
418

----------------
419
cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
420
             -> CvtM ( LHsContext GhcPs
421
                     , Located RdrName
422
                     , LHsQTyVars GhcPs)
423
cvt_tycl_hdr cxt tc tvs
424
425
426
  = do { cxt' <- cvtContext cxt
       ; tc'  <- tconNameL tc
       ; tvs' <- cvtTvs tvs
427
       ; return (cxt', tc', tvs')
428
429
430
       }

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

440
441
442
----------------
cvt_tyfam_head :: TypeFamilyHead
               -> CvtM ( Located RdrName
443
444
445
                       , LHsQTyVars GhcPs
                       , Hs.LFamilyResultSig GhcPs
                       , Maybe (Hs.LInjectivityAnn GhcPs))
446
447
448
449
450
451
452

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') }

453
-------------------------------------------------------------------
454
--              Partitioning declarations
455
456
-------------------------------------------------------------------

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

461
is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs)
462
463
464
is_tyfam_inst (L loc (Hs.InstD (TyFamInstD { tfid_inst = d }))) = Left (L loc d)
is_tyfam_inst decl                                              = Right decl

465
466
is_datafam_inst :: LHsDecl GhcPs
                -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs)
467
468
is_datafam_inst (L loc (Hs.InstD (DataFamInstD { dfid_inst = d }))) = Left (L loc d)
is_datafam_inst decl                                                = Right decl
469

470
is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)
471
472
473
is_sig (L loc (Hs.SigD sig)) = Left (L loc sig)
is_sig decl                  = Right decl

474
is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)
475
is_bind (L loc (Hs.ValD bind)) = Left (L loc bind)
476
is_bind decl                   = Right decl
477

478
mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc
479
mkBadDecMsg doc bads
480
  = sep [ text "Illegal declaration(s) in" <+> doc <> colon
481
482
        , nest 2 (vcat (map Outputable.ppr bads)) ]

483
---------------------------------------------------
484
--      Data types
485
486
---------------------------------------------------

487
cvtConstr :: TH.Con -> CvtM (LConDecl GhcPs)
488

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

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

cvtConstr (InfixC st1 c st2)
503
  = do  { c'   <- cNameL c
504
505
506
        ; cxt' <- returnL []
        ; st1' <- cvt_arg st1
        ; st2' <- cvt_arg st2
Alan Zimmerman's avatar
Alan Zimmerman committed
507
        ; returnL $ mkConDeclH98 c' Nothing cxt' (InfixCon st1' st2') }
508
509

cvtConstr (ForallC tvs ctxt con)
510
  = do  { tvs'        <- cvtTvs tvs
511
        ; L loc ctxt' <- cvtContext ctxt
512
513
514
        ; L _ con'    <- cvtConstr con
        ; returnL $ case con' of
                ConDeclGADT { con_type = conT } ->
515
516
517
                  let hs_ty  = mkHsForAllTy tvs noSrcSpan tvs' rho_ty
                      rho_ty = mkHsQualTy ctxt noSrcSpan (L loc ctxt')
                                                         (hsib_body conT)
Richard Eisenberg's avatar
Richard Eisenberg committed
518
                  in con' { con_type = mkHsImplicitBndrs hs_ty }
519
520
521
522
523
524
525
526
527
528
529
530
                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'))) } }

531
532
533
534
535
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'
536
537
        ; returnL $ mkGadtDecl c' (mkLHsSigType c_ty)}

538
cvtConstr (RecGadtC c varstrtys ty)
539
  = do  { c'       <- mapM cNameL c
540
        ; ty'      <- cvtType ty
541
        ; rec_flds <- mapM cvt_id_arg varstrtys
542
        ; let rec_ty = noLoc (HsFunTy (noLoc $ HsRecTy rec_flds) ty')
543
        ; returnL $ mkGadtDecl c' (mkLHsSigType rec_ty) }
544

545
546
547
548
549
550
551
552
553
554
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

555
cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType GhcPs)
556
cvt_arg (Bang su ss, ty)
557
558
  = do { ty'' <- cvtType ty
       ; ty' <- wrap_apps ty''
559
560
       ; let su' = cvtSrcUnpackedness su
       ; let ss' = cvtSrcStrictness ss
Alan Zimmerman's avatar
Alan Zimmerman committed
561
       ; returnL $ HsBangTy (HsSrcBang NoSourceText su' ss') ty' }
562

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

573
cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs)
Ryan Scott's avatar
Ryan Scott committed
574
575
cvtDerivs cs = do { cs' <- mapM cvtDerivClause cs
                  ; returnL cs' }
576

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


------------------------------------------
584
--      Foreign declarations
585
586
------------------------------------------

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

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

629
cvt_conv :: TH.Callconv -> CCallConv
630
631
632
633
634
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
635

636
637
638
639
------------------------------------------
--              Pragmas
------------------------------------------

640
cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs))
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
641
642
643
cvtPragmaD (InlineP nm inline rm phases)
  = do { nm' <- vNameL nm
       ; let dflt = dfltActivation inline
Alan Zimmerman's avatar
Alan Zimmerman committed
644
645
646
647
       ; 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
648
                                 , inl_inline = cvtInline inline
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
649
650
651
                                 , inl_rule   = cvtRuleMatch rm
                                 , inl_act    = cvtPhases phases dflt
                                 , inl_sat    = Nothing }
652
       ; returnJustL $ Hs.SigD $ InlineSig nm' ip }
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
653
654

cvtPragmaD (SpecialiseP nm ty inline phases)
655
656
  = do { nm' <- vNameL nm
       ; ty' <- cvtType ty
Alan Zimmerman's avatar
Alan Zimmerman committed
657
658
659
660
661
662
663
664
665
       ; 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
666
                               , inl_inline = inline'
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
667
668
669
                               , inl_rule   = Hs.FunLike
                               , inl_act    = cvtPhases phases dflt
                               , inl_sat    = Nothing }
670
       ; returnJustL $ Hs.SigD $ SpecSig nm' [mkLHsSigType ty'] ip }
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
671
672
673

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

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

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

cvtPragmaD (LineP line file)
  = do { setL (srcLocSpan (mkSrcLoc (fsLit file) line 1))
       ; return Nothing
707
       }
708
709
710
711
712
cvtPragmaD (CompleteP cls mty)
  = do { cls' <- noLoc <$> mapM cNameL cls
       ; mty'  <- traverse tconNameL mty
       ; returnJustL $ Hs.SigD
                   $ CompleteMatchSig NoSourceText cls' mty' }
713

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

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

741
---------------------------------------------------
742
--              Declarations
743
---------------------------------------------------
744

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

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


767
-------------------------------------------------------------------
768