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

5 6

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

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

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

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

39
import qualified Data.ByteString as BS
Austin Seipp's avatar
Austin Seipp committed
40
import Control.Monad( unless, liftM, ap )
41

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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



278

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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