ThToHs.hs 83.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 Hs syntax
Austin Seipp's avatar
Austin Seipp committed
7
-}
8

9
{-# LANGUAGE DeriveFunctor #-}
10
{-# LANGUAGE FlexibleContexts #-}
Matthew Pickering's avatar
Matthew Pickering committed
11
{-# LANGUAGE ScopedTypeVariables #-}
12
{-# LANGUAGE TypeFamilies #-}
13
{-# LANGUAGE ViewPatterns #-}
14

15 16 17 18 19 20 21 22
module GHC.ThToHs
   ( convertToHsExpr
   , convertToPat
   , convertToHsDecls
   , convertToHsType
   , thRdrNameGuesses
   )
where
23

24 25
import GhcPrelude

26
import GHC.Hs as Hs
Ryan Scott's avatar
Ryan Scott committed
27
import PrelNames
28 29 30 31 32 33 34
import RdrName
import qualified Name
import Module
import RdrHsSyn
import OccName
import SrcLoc
import Type
35
import qualified Coercion ( Role(..) )
36
import TysWiredIn
37
import BasicTypes as Hs
38 39 40 41
import ForeignCall
import Unique
import ErrUtils
import Bag
42
import Lexeme
43
import Util
44
import FastString
45
import Outputable
46
import MonadUtils ( foldrM )
47

48
import qualified Data.ByteString as BS
49
import Control.Monad( unless, ap )
50

51
import Data.Maybe( catMaybes, isNothing )
52 53
import Language.Haskell.TH as TH hiding (sigP)
import Language.Haskell.TH.Syntax as TH
54 55 56
import Foreign.ForeignPtr
import Foreign.Ptr
import System.IO.Unsafe
57 58

-------------------------------------------------------------------
59
--              The external interface
60

61 62
convertToHsDecls :: Origin -> SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl GhcPs]
convertToHsDecls origin loc ds = initCvt origin loc (fmap catMaybes (mapM cvt_dec ds))
63 64
  where
    cvt_dec d = wrapMsg "declaration" d (cvtDec d)
65

66 67 68
convertToHsExpr :: Origin -> SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr GhcPs)
convertToHsExpr origin loc e
  = initCvt origin loc $ wrapMsg "expression" e $ cvtl e
69

70 71 72
convertToPat :: Origin -> SrcSpan -> TH.Pat -> Either MsgDoc (LPat GhcPs)
convertToPat origin loc p
  = initCvt origin loc $ wrapMsg "pattern" p $ cvtPat p
73

74 75 76
convertToHsType :: Origin -> SrcSpan -> TH.Type -> Either MsgDoc (LHsType GhcPs)
convertToHsType origin loc t
  = initCvt origin loc $ wrapMsg "type" t $ cvtType t
77

78
-------------------------------------------------------------------
79
newtype CvtM a = CvtM { unCvtM :: Origin -> SrcSpan -> Either MsgDoc (SrcSpan, a) }
80
    deriving (Functor)
81 82
        -- Push down the Origin (that is configurable by
        -- -fenable-th-splice-warnings) and source location;
83
        -- Can fail, with a single error message
84

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

90 91 92
-- 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
93

Austin Seipp's avatar
Austin Seipp committed
94
instance Applicative CvtM where
95
    pure x = CvtM $ \_ loc -> Right (loc,x)
Austin Seipp's avatar
Austin Seipp committed
96 97
    (<*>) = ap

98
instance Monad CvtM where
99 100 101
  (CvtM m) >>= k = CvtM $ \origin loc -> case m origin loc of
    Left err -> Left err
    Right (loc',v) -> unCvtM (k v) origin loc'
102

103 104
initCvt :: Origin -> SrcSpan -> CvtM a -> Either MsgDoc a
initCvt origin loc (CvtM m) = fmap snd (m origin loc)
105

106 107
force :: a -> CvtM ()
force a = a `seq` return ()
108

109
failWith :: MsgDoc -> CvtM a
110 111 112 113
failWith m = CvtM (\_ _ -> Left m)

getOrigin :: CvtM Origin
getOrigin = CvtM (\origin loc -> Right (loc,origin))
114

115
getL :: CvtM SrcSpan
116
getL = CvtM (\_ loc -> Right (loc,loc))
117 118

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

121
returnL :: HasSrcSpan a => SrcSpanLess a -> CvtM a
122
returnL x = CvtM (\_ loc -> Right (loc, cL loc x))
123

124
returnJustL :: HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)
125
returnJustL = fmap Just . returnL
126

127 128
wrapParL :: HasSrcSpan a =>
            (a -> SrcSpanLess a) -> SrcSpanLess a -> CvtM (SrcSpanLess  a)
129
wrapParL add_par x = CvtM (\_ loc -> Right (loc, add_par (cL loc x)))
130

131 132 133
wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b
-- E.g  wrapMsg "declaration" dec thing
wrapMsg what item (CvtM m)
134 135 136
  = CvtM $ \origin loc -> case m origin loc of
      Left err -> Left (err $$ getPprStyle msg)
      Right v  -> Right v
137
  where
138 139
        -- Show the item in pretty syntax normally,
        -- but with all its constructors if you say -dppr-debug
140
    msg sty = hang (text "When splicing a TH" <+> text what <> colon)
141
                 2 (if debugStyle sty
142 143 144
                    then text (show item)
                    else text (pprint item))

145
wrapL :: HasSrcSpan a => CvtM (SrcSpanLess a) -> CvtM a
146 147 148
wrapL (CvtM m) = CvtM $ \origin loc -> case m origin loc of
  Left err -> Left err
  Right (loc',v) -> Right (loc',cL loc v)
149 150

-------------------------------------------------------------------
151
cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs]
152 153
cvtDecs = fmap catMaybes . mapM cvtDec

154
cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl GhcPs))
155
cvtDec (TH.ValD pat body ds)
156
  | TH.VarP s <- pat
157
  = do  { s' <- vNameL s
158
        ; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds)
159 160
        ; th_origin <- getOrigin
        ; returnJustL $ Hs.ValD noExtField $ mkFunBind th_origin s' [cl'] }
161

162
  | otherwise
163 164
  = do  { pat' <- cvtPat pat
        ; body' <- cvtGuard body
165
        ; ds' <- cvtLocalDecs (text "a where clause") ds
166
        ; returnJustL $ Hs.ValD noExtField $
167
          PatBind { pat_lhs = pat'
168 169
                  , pat_rhs = GRHSs noExtField body' (noLoc ds')
                  , pat_ext = noExtField
170
                  , pat_ticks = ([],[]) } }
171

172
cvtDec (TH.FunD nm cls)
173
  | null cls
174
  = failWith (text "Function binding for"
175
                 <+> quotes (text (TH.pprint nm))
176
                 <+> text "has no equations")
177
  | otherwise
178
  = do  { nm' <- vNameL nm
179
        ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls
180 181
        ; th_origin <- getOrigin
        ; returnJustL $ Hs.ValD noExtField $ mkFunBind th_origin nm' cls' }
182

183
cvtDec (TH.SigD nm typ)
184
  = do  { nm' <- vNameL nm
185
        ; ty' <- cvtType typ
186 187
        ; returnJustL $ Hs.SigD noExtField
                                    (TypeSig noExtField [nm'] (mkLHsSigWcType ty')) }
188

189 190 191 192 193 194
cvtDec (TH.KiSigD nm ki)
  = do  { nm' <- tconNameL nm
        ; ki' <- cvtType ki
        ; let sig' = StandaloneKindSig noExtField nm' (mkLHsSigType ki')
        ; returnJustL $ Hs.KindSigD noExtField sig' }

195
cvtDec (TH.InfixD fx nm)
196
  -- Fixity signatures are allowed for variables, constructors, and types
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
197 198 199 200
  -- 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
201 202
       ; returnJustL (Hs.SigD noExtField (FixSig noExtField
                                      (FixitySig noExtField [nm'] (cvtFixity fx)))) }
203

204
cvtDec (PragmaD prag)
205
  = cvtPragmaD prag
206 207

cvtDec (TySynD tc tvs rhs)
208 209
  = do  { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
        ; rhs' <- cvtType rhs
210 211
        ; returnJustL $ TyClD noExtField $
          SynDecl { tcdSExt = noExtField, tcdLName = tc', tcdTyVars = tvs'
212
                  , tcdFixity = Prefix
213
                  , tcdRhs = rhs' } }
214

215
cvtDec (DataD ctxt tc tvs ksig constrs derivs)
216 217 218 219
  = do  { let isGadtCon (GadtC    _ _ _) = True
              isGadtCon (RecGadtC _ _ _) = True
              isGadtCon (ForallC  _ _ c) = isGadtCon c
              isGadtCon _                = False
220 221 222 223 224 225 226 227 228
              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
229 230
        ; cons' <- mapM cvtConstr constrs
        ; derivs' <- cvtDerivs derivs
231
        ; let defn = HsDataDefn { dd_ext = noExtField
232
                                , dd_ND = DataType, dd_cType = Nothing
233
                                , dd_ctxt = ctxt'
234
                                , dd_kindSig = ksig'
235
                                , dd_cons = cons', dd_derivs = derivs' }
236 237 238 239 240
        ; returnJustL $ TyClD noExtField $
          DataDecl { tcdDExt = noExtField
                   , tcdLName = tc', tcdTyVars = tvs'
                   , tcdFixity = Prefix
                   , tcdDataDefn = defn } }
241

242
cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)
243
  = do  { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
244
        ; ksig' <- cvtKind `traverse` ksig
245 246
        ; con' <- cvtConstr constr
        ; derivs' <- cvtDerivs derivs
247
        ; let defn = HsDataDefn { dd_ext = noExtField
248
                                , dd_ND = NewType, dd_cType = Nothing
249
                                , dd_ctxt = ctxt'
250
                                , dd_kindSig = ksig'
251 252
                                , dd_cons = [con']
                                , dd_derivs = derivs' }
253 254 255 256 257
        ; returnJustL $ TyClD noExtField $
          DataDecl { tcdDExt = noExtField
                   , tcdLName = tc', tcdTyVars = tvs'
                   , tcdFixity = Prefix
                   , tcdDataDefn = defn } }
258

259
cvtDec (ClassD ctxt cl tvs fds decs)
260 261
  = do  { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
        ; fds'  <- mapM cvt_fundep fds
262
        ; (binds', sigs', fams', at_defs', adts') <- cvt_ci_decs (text "a class declaration") decs
263
        ; unless (null adts')
264 265
            (failWith $ (text "Default data instance declarations"
                     <+> text "are not allowed:")
266
                   $$ (Outputable.ppr adts'))
267 268
        ; returnJustL $ TyClD noExtField $
          ClassDecl { tcdCExt = noExtField
269
                    , tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
270
                    , tcdFixity = Prefix
271 272
                    , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'
                    , tcdMeths = binds'
273
                    , tcdATs = fams', tcdATDefs = at_defs', tcdDocs = [] }
274
                              -- no docs in TH ^^
275
        }
276

277
cvtDec (InstanceD o ctxt ty decs)
278
  = do  { let doc = text "an instance declaration"
279
        ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs
280
        ; unless (null fams') (failWith (mkBadDecMsg doc fams'))
281
        ; ctxt' <- cvtContext funPrec ctxt
282 283
        ; (dL->L loc ty') <- cvtType ty
        ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ cL loc ty'
284 285
        ; returnJustL $ InstD noExtField $ ClsInstD noExtField $
          ClsInstDecl { cid_ext = noExtField, cid_poly_ty = mkLHsSigType inst_ty'
286 287 288
                      , cid_binds = binds'
                      , cid_sigs = Hs.mkClassOpSigs sigs'
                      , cid_tyfam_insts = ats', cid_datafam_insts = adts'
289
                      , cid_overlap_mode = fmap (cL loc . overlap) o } }
290 291 292
  where
  overlap pragma =
    case pragma of
293 294 295 296
      TH.Overlaps      -> Hs.Overlaps     (SourceText "OVERLAPS")
      TH.Overlappable  -> Hs.Overlappable (SourceText "OVERLAPPABLE")
      TH.Overlapping   -> Hs.Overlapping  (SourceText "OVERLAPPING")
      TH.Incoherent    -> Hs.Incoherent   (SourceText "INCOHERENT")
297 298 299



300

301
cvtDec (ForeignD ford)
302
  = do { ford' <- cvtForD ford
303
       ; returnJustL $ ForD noExtField ford' }
304

Jan Stolarek's avatar
Jan Stolarek committed
305
cvtDec (DataFamilyD tc tvs kind)
306
  = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
Jan Stolarek's avatar
Jan Stolarek committed
307
       ; result <- cvtMaybeKindToFamilyResultSig kind
308 309
       ; returnJustL $ TyClD noExtField $ FamDecl noExtField $
         FamilyDecl noExtField DataFamily tc' tvs' Prefix result Nothing }
310

My Nguyen's avatar
My Nguyen committed
311 312
cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs)
  = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys
313
       ; ksig' <- cvtKind `traverse` ksig
314 315
       ; cons' <- mapM cvtConstr constrs
       ; derivs' <- cvtDerivs derivs
316
       ; let defn = HsDataDefn { dd_ext = noExtField
317
                               , dd_ND = DataType, dd_cType = Nothing
318
                               , dd_ctxt = ctxt'
319
                               , dd_kindSig = ksig'
320
                               , dd_cons = cons', dd_derivs = derivs' }
321

322 323
       ; returnJustL $ InstD noExtField $ DataFamInstD
           { dfid_ext = noExtField
324
           , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $
325
                           FamEqn { feqn_ext = noExtField
326 327 328
                                  , feqn_tycon = tc'
                                  , feqn_bndrs = bndrs'
                                  , feqn_pats = typats'
329 330
                                  , feqn_rhs = defn
                                  , feqn_fixity = Prefix } }}}
331

My Nguyen's avatar
My Nguyen committed
332 333
cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs)
  = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys
334
       ; ksig' <- cvtKind `traverse` ksig
335 336
       ; con' <- cvtConstr constr
       ; derivs' <- cvtDerivs derivs
337
       ; let defn = HsDataDefn { dd_ext = noExtField
338
                               , dd_ND = NewType, dd_cType = Nothing
339
                               , dd_ctxt = ctxt'
340
                               , dd_kindSig = ksig'
341
                               , dd_cons = [con'], dd_derivs = derivs' }
342 343
       ; returnJustL $ InstD noExtField $ DataFamInstD
           { dfid_ext = noExtField
344
           , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $
345
                           FamEqn { feqn_ext = noExtField
346 347 348
                                  , feqn_tycon = tc'
                                  , feqn_bndrs = bndrs'
                                  , feqn_pats = typats'
349 350
                                  , feqn_rhs = defn
                                  , feqn_fixity = Prefix } }}}
351

My Nguyen's avatar
My Nguyen committed
352 353
cvtDec (TySynInstD eqn)
  = do  { (dL->L _ eqn') <- cvtTySynEqn eqn
354 355
        ; returnJustL $ InstD noExtField $ TyFamInstD
            { tfid_ext = noExtField
356
            , tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } }
357

358 359
cvtDec (OpenTypeFamilyD head)
  = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
360 361
       ; returnJustL $ TyClD noExtField $ FamDecl noExtField $
         FamilyDecl noExtField OpenTypeFamily tc' tyvars' Prefix result' injectivity'
362
       }
Jan Stolarek's avatar
Jan Stolarek committed
363

364 365
cvtDec (ClosedTypeFamilyD head eqns)
  = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
My Nguyen's avatar
My Nguyen committed
366
       ; eqns' <- mapM cvtTySynEqn eqns
367 368
       ; returnJustL $ TyClD noExtField $ FamDecl noExtField $
         FamilyDecl noExtField (ClosedTypeFamily (Just eqns')) tc' tyvars' Prefix
369
                           result' injectivity' }
370 371 372 373

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

Ryan Scott's avatar
Ryan Scott committed
376
cvtDec (TH.StandaloneDerivD ds cxt ty)
377
  = do { cxt' <- cvtContext funPrec cxt
Ryan Scott's avatar
Ryan Scott committed
378
       ; ds'  <- traverse cvtDerivStrategy ds
379 380
       ; (dL->L loc ty') <- cvtType ty
       ; let inst_ty' = mkHsQualTy cxt loc cxt' $ cL loc ty'
381 382
       ; returnJustL $ DerivD noExtField $
         DerivDecl { deriv_ext =noExtField
Ryan Scott's avatar
Ryan Scott committed
383
                   , deriv_strategy = ds'
384
                   , deriv_type = mkLHsSigWcType inst_ty'
Ryan Scott's avatar
Ryan Scott committed
385
                   , deriv_overlap_mode = Nothing } }
386 387 388 389

cvtDec (TH.DefaultSigD nm typ)
  = do { nm' <- vNameL nm
       ; ty' <- cvtType typ
390 391
       ; returnJustL $ Hs.SigD noExtField
                     $ ClassOpSig noExtField True [nm'] (mkLHsSigType ty')}
392 393 394 395

cvtDec (TH.PatSynD nm args dir pat)
  = do { nm'   <- cNameL nm
       ; args' <- cvtArgs args
396
       ; dir'  <- cvtDir nm' dir
397
       ; pat'  <- cvtPat pat
398 399
       ; returnJustL $ Hs.ValD noExtField $ PatSynBind noExtField $
           PSB noExtField nm' args' pat' dir' }
400
  where
401 402
    cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon <$> mapM vNameL args
    cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameL a1 <*> vNameL a2
403 404 405
    cvtArgs (TH.RecordPatSyn sels)
      = do { sels' <- mapM vNameL sels
           ; vars' <- mapM (vNameL . mkNameS . nameBase) sels
406
           ; return $ Hs.RecCon $ zipWith RecordPatSynField sels' vars' }
407

408 409 410
    cvtDir _ Unidir          = return Unidirectional
    cvtDir _ ImplBidir       = return ImplicitBidirectional
    cvtDir n (ExplBidir cls) =
411
      do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls
412 413
         ; th_origin <- getOrigin
         ; return $ ExplicitBidirectional $ mkMatchGroup th_origin ms }
414 415 416 417

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

420 421 422 423 424 425
-- Implicit parameter bindings are handled in cvtLocalDecs and
-- cvtImplicitParamBind. They are not allowed in any other scope, so
-- reaching this case indicates an error.
cvtDec (TH.ImplicitParamBindD _ _)
  = failWith (text "Implicit parameter binding only allowed in let or where")

426
----------------
My Nguyen's avatar
My Nguyen committed
427 428 429 430 431 432 433
cvtTySynEqn :: TySynEqn -> CvtM (LTyFamInstEqn GhcPs)
cvtTySynEqn (TySynEqn mb_bndrs lhs rhs)
  = do { mb_bndrs' <- traverse (mapM cvt_tv) mb_bndrs
       ; (head_ty, args) <- split_ty_app lhs
       ; case head_ty of
           ConT nm -> do { nm' <- tconNameL nm
                         ; rhs' <- cvtType rhs
434
                         ; let args' = map wrap_tyarg args
My Nguyen's avatar
My Nguyen committed
435
                         ; returnL $ mkHsImplicitBndrs
436
                            $ FamEqn { feqn_ext    = noExtField
My Nguyen's avatar
My Nguyen committed
437 438 439 440 441 442 443 444 445
                                     , feqn_tycon  = nm'
                                     , feqn_bndrs  = mb_bndrs'
                                     , feqn_pats   = args'
                                     , feqn_fixity = Prefix
                                     , feqn_rhs    = rhs' } }
           InfixT t1 nm t2 -> do { nm' <- tconNameL nm
                                 ; args' <- mapM cvtType [t1,t2]
                                 ; rhs' <- cvtType rhs
                                 ; returnL $ mkHsImplicitBndrs
446
                                      $ FamEqn { feqn_ext    = noExtField
My Nguyen's avatar
My Nguyen committed
447 448 449 450 451 452 453 454 455
                                               , feqn_tycon  = nm'
                                               , feqn_bndrs  = mb_bndrs'
                                               , feqn_pats   =
                                                (map HsValArg args') ++ args
                                               , feqn_fixity = Hs.Infix
                                               , feqn_rhs    = rhs' } }
           _ -> failWith $ text "Invalid type family instance LHS:"
                          <+> text (show lhs)
        }
456

457
----------------
458
cvt_ci_decs :: MsgDoc -> [TH.Dec]
459 460 461 462 463
            -> CvtM (LHsBinds GhcPs,
                     [LSig GhcPs],
                     [LFamilyDecl GhcPs],
                     [LTyFamInstDecl GhcPs],
                     [LDataFamInstDecl GhcPs])
464 465 466
-- Convert the declarations inside a class or instance decl
-- ie signatures, bindings, and associated types
cvt_ci_decs doc decs
467
  = do  { decs' <- cvtDecs decs
468 469 470
        ; 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'
471
        ; let (binds', prob_fams')   = partitionWith is_bind prob_binds'
472
        ; let (fams', bads)          = partitionWith is_fam_decl prob_fams'
473
        ; unless (null bads) (failWith (mkBadDecMsg doc bads))
474
        ; return (listToBag binds', sigs', fams', ats', adts') }
475 476

----------------
477
cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
478
             -> CvtM ( LHsContext GhcPs
479
                     , Located RdrName
480
                     , LHsQTyVars GhcPs)
481
cvt_tycl_hdr cxt tc tvs
482
  = do { cxt' <- cvtContext funPrec cxt
483 484
       ; tc'  <- tconNameL tc
       ; tvs' <- cvtTvs tvs
485
       ; return (cxt', tc', tvs')
486 487
       }

My Nguyen's avatar
My Nguyen committed
488
cvt_datainst_hdr :: TH.Cxt -> Maybe [TH.TyVarBndr] -> TH.Type
489
               -> CvtM ( LHsContext GhcPs
490
                       , Located RdrName
491
                       , Maybe [LHsTyVarBndr GhcPs]
492
                       , HsTyPats GhcPs)
My Nguyen's avatar
My Nguyen committed
493
cvt_datainst_hdr cxt bndrs tys
494
  = do { cxt' <- cvtContext funPrec cxt
495
       ; bndrs' <- traverse (mapM cvt_tv) bndrs
My Nguyen's avatar
My Nguyen committed
496 497 498
       ; (head_ty, args) <- split_ty_app tys
       ; case head_ty of
          ConT nm -> do { nm' <- tconNameL nm
499
                        ; let args' = map wrap_tyarg args
My Nguyen's avatar
My Nguyen committed
500 501 502 503 504 505 506
                        ; return (cxt', nm', bndrs', args') }
          InfixT t1 nm t2 -> do { nm' <- tconNameL nm
                                ; args' <- mapM cvtType [t1,t2]
                                ; return (cxt', nm', bndrs',
                                         ((map HsValArg args') ++ args)) }
          _ -> failWith $ text "Invalid type instance header:"
                          <+> text (show tys) }
507

508 509 510
----------------
cvt_tyfam_head :: TypeFamilyHead
               -> CvtM ( Located RdrName
511 512 513
                       , LHsQTyVars GhcPs
                       , Hs.LFamilyResultSig GhcPs
                       , Maybe (Hs.LInjectivityAnn GhcPs))
514 515 516 517 518 519 520

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

521
-------------------------------------------------------------------
522
--              Partitioning declarations
523 524
-------------------------------------------------------------------

525
is_fam_decl :: LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs)
526
is_fam_decl (dL->L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (cL loc d)
527 528
is_fam_decl decl = Right decl

529
is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs)
530 531
is_tyfam_inst (dL->L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d })))
  = Left (cL loc d)
532 533
is_tyfam_inst decl
  = Right decl
534

535 536
is_datafam_inst :: LHsDecl GhcPs
                -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs)
537 538
is_datafam_inst (dL->L loc (Hs.InstD  _ (DataFamInstD { dfid_inst = d })))
  = Left (cL loc d)
539 540
is_datafam_inst decl
  = Right decl
541

542
is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)
543 544
is_sig (dL->L loc (Hs.SigD _ sig)) = Left (cL loc sig)
is_sig decl                        = Right decl
545

546
is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)
547 548
is_bind (dL->L loc (Hs.ValD _ bind)) = Left (cL loc bind)
is_bind decl                         = Right decl
549

550 551 552 553
is_ip_bind :: TH.Dec -> Either (String, TH.Exp) TH.Dec
is_ip_bind (TH.ImplicitParamBindD n e) = Left (n, e)
is_ip_bind decl             = Right decl

554
mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc
555
mkBadDecMsg doc bads
556
  = sep [ text "Illegal declaration(s) in" <+> doc <> colon
557 558
        , nest 2 (vcat (map Outputable.ppr bads)) ]

559
---------------------------------------------------
560
--      Data types
561 562
---------------------------------------------------

563
cvtConstr :: TH.Con -> CvtM (LConDecl GhcPs)
564

565
cvtConstr (NormalC c strtys)
566 567
  = do  { c'   <- cNameL c
        ; tys' <- mapM cvt_arg strtys
568
        ; returnL $ mkConDeclH98 c' Nothing Nothing (PrefixCon tys') }
569 570

cvtConstr (RecC c varstrtys)
571 572
  = do  { c'    <- cNameL c
        ; args' <- mapM cvt_id_arg varstrtys
573
        ; returnL $ mkConDeclH98 c' Nothing Nothing
Alan Zimmerman's avatar
Alan Zimmerman committed
574
                                   (RecCon (noLoc args')) }
575 576

cvtConstr (InfixC st1 c st2)
577
  = do  { c'   <- cNameL c
578 579
        ; st1' <- cvt_arg st1
        ; st2' <- cvt_arg st2
580
        ; returnL $ mkConDeclH98 c' Nothing Nothing (InfixCon st1' st2') }
581 582

cvtConstr (ForallC tvs ctxt con)
583
  = do  { tvs'      <- cvtTvs tvs
584
        ; ctxt'     <- cvtContext funPrec ctxt
585
        ; (dL->L _ con')  <- cvtConstr con
586 587 588
        ; returnL $ add_forall tvs' ctxt' con' }
  where
    add_cxt lcxt         Nothing           = Just lcxt
589 590
    add_cxt (dL->L loc cxt1) (Just (dL->L _ cxt2))
      = Just (cL loc (cxt1 ++ cxt2))
591 592

    add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt })
593
      = con { con_forall = noLoc $ not (null all_tvs)
594 595 596 597 598 599
            , con_qvars  = mkHsQTvs all_tvs
            , con_mb_cxt = add_cxt cxt' cxt }
      where
        all_tvs = hsQTvExplicit tvs' ++ hsQTvExplicit qvars

    add_forall tvs' cxt' con@(ConDeclH98 { con_ex_tvs = ex_tvs, con_mb_cxt = cxt })
600
      = con { con_forall = noLoc $ not (null all_tvs)
601 602 603 604
            , con_ex_tvs = all_tvs
            , con_mb_cxt = add_cxt cxt' cxt }
      where
        all_tvs = hsQTvExplicit tvs' ++ ex_tvs
605

606
    add_forall _ _ (XConDecl nec) = noExtCon nec
607

608 609 610
cvtConstr (GadtC [] _strtys _ty)
  = failWith (text "GadtC must have at least one constructor name")

611 612 613
cvtConstr (GadtC c strtys ty)
  = do  { c'      <- mapM cNameL c
        ; args    <- mapM cvt_arg strtys
614
        ; (dL->L _ ty') <- cvtType ty
615
        ; c_ty    <- mk_arr_apps args ty'
616
        ; returnL $ fst $ mkGadtDecl c' c_ty}
617

618 619 620
cvtConstr (RecGadtC [] _varstrtys _ty)
  = failWith (text "RecGadtC must have at least one constructor name")

621
cvtConstr (RecGadtC c varstrtys ty)
622
  = do  { c'       <- mapM cNameL c
623
        ; ty'      <- cvtType ty
624
        ; rec_flds <- mapM cvt_id_arg varstrtys
625 626
        ; let rec_ty = noLoc (HsFunTy noExtField
                                           (noLoc $ HsRecTy noExtField rec_flds) ty')
627
        ; returnL $ fst $ mkGadtDecl c' rec_ty }
628

629 630 631 632 633 634 635 636 637 638
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

639
cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType GhcPs)
640
cvt_arg (Bang su ss, ty)
641
  = do { ty'' <- cvtType ty
642 643 644
       ; let ty' = parenthesizeHsType appPrec ty''
             su' = cvtSrcUnpackedness su
             ss' = cvtSrcStrictness ss
645
       ; returnL $ HsBangTy noExtField (HsSrcBang NoSourceText su' ss') ty' }
646

647
cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs)
648
cvt_id_arg (i, str, ty)
649
  = do  { (dL->L li i') <- vNameL i
650
        ; ty' <- cvt_arg (str,ty)
651
        ; return $ noLoc (ConDeclField
652
                          { cd_fld_ext = noExtField
653
                          , cd_fld_names
654
                              = [cL li $ FieldOcc noExtField (cL li i')]
655 656
                          , cd_fld_type =  ty'
                          , cd_fld_doc = Nothing}) }
657

658
cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs)
Ryan Scott's avatar
Ryan Scott committed
659 660
cvtDerivs cs = do { cs' <- mapM cvtDerivClause cs
                  ; returnL cs' }
661

662
cvt_fundep :: FunDep -> CvtM (LHsFunDep GhcPs)
663 664 665
cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs
                               ; ys' <- mapM tNameL ys
                               ; returnL (xs', ys') }
666 667 668


------------------------------------------
669
--      Foreign declarations
670 671
------------------------------------------

672
cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs)
673
cvtForD (ImportF callconv safety from nm ty)
674 675 676 677
  -- 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
678 679
                    (CFunction (StaticTarget (SourceText from)
                                             (mkFastString from) Nothing
680
                                             True))
681
                    (noLoc $ quotedSourceText from))
682 683
  | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety')
                                 (mkFastString (TH.nameBase nm))
684
                                 from (noLoc $ quotedSourceText from)
685
  = mk_imp impspec
686
  | otherwise
687
  = failWith $ text (show from) <+> text "is not a valid ccall impent"
688
  where
689 690 691
    mk_imp impspec
      = do { nm' <- vNameL nm
           ; ty' <- cvtType ty
692
           ; return (ForeignImport { fd_i_ext = noExtField
693
                                   , fd_name = nm'
694 695
                                   , fd_sig_ty = mkLHsSigType ty'
                                   , fd_fi = impspec })
696
           }
697 698
    safety' = case safety of
                     Unsafe     -> PlayRisky
Ian Lynagh's avatar
Ian Lynagh committed
699
                     Safe       -> PlaySafe
700
                     Interruptible -> PlayInterruptible
701 702

cvtForD (ExportF callconv as nm ty)
703 704
  = do  { nm' <- vNameL nm
        ; ty' <- cvtType ty
705
        ; let e = CExport (noLoc (CExportStatic (SourceText as)
706
                                                (mkFastString as)
707
                                                (cvt_conv callconv)))
708
                                                (noLoc (SourceText as))
709
        ; return $ ForeignExport { fd_e_ext = noExtField
710
                                 , fd_name = nm'
711 712
                                 , fd_sig_ty = mkLHsSigType ty'
                                 , fd_fe = e } }
713

714
cvt_conv :: TH.Callconv -> CCallConv
715 716 717 718 719
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
720

721 722 723 724
------------------------------------------
--              Pragmas
------------------------------------------

725
cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs))
726 727 728
cvtPragmaD (InlineP nm inline rm phases)
  = do { nm' <- vNameL nm
       ; let dflt = dfltActivation inline
729 730 731 732
       ; 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
733
                                 , inl_inline = cvtInline inline
734 735 736
                                 , inl_rule   = cvtRuleMatch rm
                                 , inl_act    = cvtPhases phases dflt
                                 , inl_sat    = Nothing }
737
       ; returnJustL $ Hs.SigD noExtField $ InlineSig noExtField nm' ip }
738 739

cvtPragmaD (SpecialiseP nm ty inline phases)
740 741
  = do { nm' <- vNameL nm
       ; ty' <- cvtType ty
742 743 744 745 746 747
       ; 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)
748
               Nothing      -> (NoUserInline,   AlwaysActive,
749 750
                                "{-# SPECIALISE")
       ; let ip = InlinePragma { inl_src    = SourceText srcText
Alan Zimmerman's avatar
Alan Zimmerman committed
751
                               , inl_inline = inline'
752 753 754
                               , inl_rule   = Hs.FunLike
                               , inl_act    = cvtPhases phases dflt
                               , inl_sat    = Nothing }
755
       ; returnJustL $ Hs.SigD noExtField $ SpecSig noExtField nm' [mkLHsSigType ty'] ip }
756 757 758

cvtPragmaD (SpecialiseInstP ty)
  = do { ty' <- cvtType ty
759 760
       ; returnJustL $ Hs.SigD noExtField $
         SpecInstSig noExtField (SourceText "{-# SPECIALISE") (mkLHsSigType ty') }
761

762
cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases)
763 764
  = do { let nm' = mkFastString nm
       ; let act = cvtPhases phases AlwaysActive
765 766
       ; ty_bndrs' <- traverse (mapM cvt_tv) ty_bndrs
       ; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs
767 768
       ; lhs'   <- cvtl lhs
       ; rhs'   <- cvtl rhs
769 770
       ; returnJustL $ Hs.RuleD noExtField
            $ HsRules { rds_ext = noExtField
771 772
                      , rds_src = SourceText "{-# RULES"
                      , rds_rules = [noLoc $
773
                          HsRule { rd_ext  = noExtField
774 775 776 777 778 779 780 781
                                 , rd_name = (noLoc (quotedSourceText nm,nm'))
                                 , rd_act  = act
                                 , rd_tyvs = ty_bndrs'
                                 , rd_tmvs = tm_bndrs'
                                 , rd_lhs  = lhs'
                                 , rd_rhs  = rhs' }] }

          }
782

783 784 785 786 787 788
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
789
           return (TypeAnnProvenance  (noLoc n'))
790
         ValueAnnotation n -> do
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
791
           n' <- vcName n
Alan Zimmerman's avatar
Alan Zimmerman committed
792
           return (ValueAnnProvenance (noLoc n'))
793 794
       ; returnJustL $ Hs.AnnD noExtField
                     $ HsAnnotation noExtField (SourceText "{-# ANN") target' exp'
795 796 797 798 799
       }

cvtPragmaD (LineP line file)
  = do { setL (srcLocSpan (mkSrcLoc (fsLit file) line 1))
       ; return Nothing
800
       }
801 802 803
cvtPragmaD (CompleteP cls mty)
  = do { cls' <- noLoc <$> mapM cNameL cls
       ; mty'  <- traverse tconNameL mty
804 805
       ; returnJustL $ Hs.SigD noExtField
                   $ CompleteMatchSig noExtField NoSourceText cls' mty' }
806

807 808 809 810 811 812 813 814 815 816 817 818 819 820 821
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
822 823
cvtPhases (FromPhase i)   _    = ActiveAfter NoSourceText i
cvtPhases (BeforePhase i) _    = ActiveBefore NoSourceText i
824

825
cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs)
826 827
cvtRuleBndr (RuleVar n)
  = do { n' <- vNameL n
828
       ; return $ noLoc $ Hs.RuleBndr noExtField n' }
829 830 831
cvtRuleBndr (TypedRuleVar n ty)
  = do { n'  <- vNameL n
       ; ty' <- cvtType ty
832
       ; return $ noLoc $ Hs.RuleBndrSig noExtField n' $ mkLHsSigWcType ty' }
833