ThToHs.hs 83.6 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
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}

18 19 20 21 22 23 24 25
module GHC.ThToHs
   ( convertToHsExpr
   , convertToPat
   , convertToHsDecls
   , convertToHsType
   , thRdrNameGuesses
   )
where
26

27 28
import GhcPrelude

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

51
import qualified Data.ByteString as BS
52
import Control.Monad( unless, ap )
53

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

-------------------------------------------------------------------
62
--              The external interface
63

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

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

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

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

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

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

93 94 95
-- 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
96

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

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

106 107
initCvt :: Origin -> SrcSpan -> CvtM a -> Either MsgDoc a
initCvt origin loc (CvtM m) = fmap snd (m origin loc)
108

109 110
force :: a -> CvtM ()
force a = a `seq` return ()
111

112
failWith :: MsgDoc -> CvtM a
113 114 115 116
failWith m = CvtM (\_ _ -> Left m)

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

118
getL :: CvtM SrcSpan
119
getL = CvtM (\_ loc -> Right (loc,loc))
120 121

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

124 125
returnL :: a -> CvtM (Located a)
returnL x = CvtM (\_ loc -> Right (loc, L loc x))
126

127
returnJustL :: a -> CvtM (Maybe (Located a))
128
returnJustL = fmap Just . returnL
129

130 131
wrapParL :: (Located a -> a) -> a -> CvtM a
wrapParL add_par x = CvtM (\_ loc -> Right (loc, add_par (L loc x)))
132

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

147
wrapL :: CvtM a -> CvtM (Located a)
148 149
wrapL (CvtM m) = CvtM $ \origin loc -> case m origin loc of
  Left err -> Left err
150
  Right (loc', v) -> Right (loc', L loc v)
151 152

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

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

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

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

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

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

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

206
cvtDec (PragmaD prag)
207
  = cvtPragmaD prag
208 209

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

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

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

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

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



302

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

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

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

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

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

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

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

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

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

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

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

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

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

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

422 423 424 425 426 427
-- 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")

428
----------------
My Nguyen's avatar
My Nguyen committed
429 430 431 432 433 434 435
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
436
                         ; let args' = map wrap_tyarg args
My Nguyen's avatar
My Nguyen committed
437
                         ; returnL $ mkHsImplicitBndrs
438
                            $ FamEqn { feqn_ext    = noExtField
My Nguyen's avatar
My Nguyen committed
439 440 441 442 443 444 445 446 447
                                     , 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
448
                                      $ FamEqn { feqn_ext    = noExtField
My Nguyen's avatar
My Nguyen committed
449 450 451 452 453 454 455 456 457
                                               , 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)
        }
458

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

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

My Nguyen's avatar
My Nguyen committed
490
cvt_datainst_hdr :: TH.Cxt -> Maybe [TH.TyVarBndr] -> TH.Type
491
               -> CvtM ( LHsContext GhcPs
492
                       , Located RdrName
493
                       , Maybe [LHsTyVarBndr GhcPs]
494
                       , HsTyPats GhcPs)
My Nguyen's avatar
My Nguyen committed
495
cvt_datainst_hdr cxt bndrs tys
496
  = do { cxt' <- cvtContext funPrec cxt
497
       ; bndrs' <- traverse (mapM cvt_tv) bndrs
My Nguyen's avatar
My Nguyen committed
498 499 500
       ; (head_ty, args) <- split_ty_app tys
       ; case head_ty of
          ConT nm -> do { nm' <- tconNameL nm
501
                        ; let args' = map wrap_tyarg args
My Nguyen's avatar
My Nguyen committed
502 503 504 505 506 507 508
                        ; 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) }
509

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

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

523
-------------------------------------------------------------------
524
--              Partitioning declarations
525 526
-------------------------------------------------------------------

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

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

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

544
is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)
545 546
is_sig (L loc (Hs.SigD _ sig)) = Left (L loc sig)
is_sig decl                    = Right decl
547

548
is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)
549 550
is_bind (L loc (Hs.ValD _ bind)) = Left (L loc bind)
is_bind decl                     = Right decl
551

552 553 554 555
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

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

561
---------------------------------------------------
562
--      Data types
563 564
---------------------------------------------------

565
cvtConstr :: TH.Con -> CvtM (LConDecl GhcPs)
566

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

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

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

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

    add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt })
595
      = con { con_forall = noLoc $ not (null all_tvs)
596 597 598 599 600 601
            , 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 })
602
      = con { con_forall = noLoc $ not (null all_tvs)
603 604 605 606
            , con_ex_tvs = all_tvs
            , con_mb_cxt = add_cxt cxt' cxt }
      where
        all_tvs = hsQTvExplicit tvs' ++ ex_tvs
607

608
    add_forall _ _ (XConDecl nec) = noExtCon nec
609

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

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

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

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

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

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

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

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

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


------------------------------------------
671
--      Foreign declarations
672 673
------------------------------------------

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

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

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

723 724 725 726
------------------------------------------
--              Pragmas
------------------------------------------

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

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

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

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

          }
784

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

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

809 810 811 812 813 814 815 816 817 818 819 820 821 822 823
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