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

5 6

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

9
{-# LANGUAGE CPP #-}
10

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

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

39
import qualified Data.ByteString as BS
Austin Seipp's avatar
Austin Seipp committed
40
import Control.Monad( unless, liftM, ap )
41
#if __GLASGOW_HASKELL__ < 709
Austin Seipp's avatar
Austin Seipp committed
42
import Control.Applicative (Applicative(..))
43
#endif
44

Alan Zimmerman's avatar
Alan Zimmerman committed
45 46
import Data.Char ( chr )
import Data.Word ( Word8 )
47
import Data.Maybe( catMaybes )
48 49
import Language.Haskell.TH as TH hiding (sigP)
import Language.Haskell.TH.Syntax as TH
50 51

-------------------------------------------------------------------
52
--              The external interface
53

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

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

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

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

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

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

81 82 83
-- 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
84

Austin Seipp's avatar
Austin Seipp committed
85 86 87 88 89 90 91
instance Functor CvtM where
    fmap = liftM

instance Applicative CvtM where
    pure = return
    (<*>) = ap

92
instance Monad CvtM where
93
  return x       = CvtM $ \loc -> Right (loc,x)
94
  (CvtM m) >>= k = CvtM $ \loc -> case m loc of
95
                                  Left err -> Left err
96
                                  Right (loc',v) -> unCvtM (k v) loc'
97

98
initCvt :: SrcSpan -> CvtM a -> Either MsgDoc a
99
initCvt loc (CvtM m) = fmap snd (m loc)
100

101 102
force :: a -> CvtM ()
force a = a `seq` return ()
103

104
failWith :: MsgDoc -> CvtM a
105
failWith m = CvtM (\_ -> Left m)
106

107
getL :: CvtM SrcSpan
108 109 110 111
getL = CvtM (\loc -> Right (loc,loc))

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

113
returnL :: a -> CvtM (Located a)
114 115 116 117
returnL x = CvtM (\loc -> Right (loc, L loc x))

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

119
wrapParL :: (Located a -> a) -> a -> CvtM a
120
wrapParL add_par x = CvtM (\loc -> Right (loc, add_par (L loc x)))
121

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

136 137
wrapL :: CvtM a -> CvtM (Located a)
wrapL (CvtM m) = CvtM (\loc -> case m loc of
138
                               Left err -> Left err
139
                               Right (loc',v) -> Right (loc',L loc v))
140 141

-------------------------------------------------------------------
142 143 144 145
cvtDecs :: [TH.Dec] -> CvtM [LHsDecl RdrName]
cvtDecs = fmap catMaybes . mapM cvtDec

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

152
  | otherwise
153 154 155
  = do  { pat' <- cvtPat pat
        ; body' <- cvtGuard body
        ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) ds
156
        ; returnJustL $ Hs.ValD $
157
          PatBind { pat_lhs = pat', pat_rhs = GRHSs body' ds'
158
                  , pat_rhs_ty = placeHolderType, bind_fvs = placeHolderNames
159
                  , pat_ticks = ([],[]) } }
160

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

171
cvtDec (TH.SigD nm typ)
172
  = do  { nm' <- vNameL nm
173
        ; ty' <- cvtType typ
thomasw's avatar
thomasw committed
174
        ; returnJustL $ Hs.SigD (TypeSig [nm'] ty' PlaceHolder) }
175

176
cvtDec (TH.InfixD fx nm)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
177 178 179 180 181
  -- fixity signatures are allowed for variables, constructors, and types
  -- 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
182
       ; returnJustL (Hs.SigD (FixSig (FixitySig [nm'] (cvtFixity fx)))) }
183

184
cvtDec (PragmaD prag)
185
  = cvtPragmaD prag
186 187

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

195
cvtDec (DataD ctxt tc tvs constrs derivs)
196 197 198
  = do  { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
        ; cons' <- mapM cvtConstr constrs
        ; derivs' <- cvtDerivs derivs
199 200 201 202
        ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
                                , dd_ctxt = ctxt'
                                , dd_kindSig = Nothing
                                , dd_cons = cons', dd_derivs = derivs' }
203 204 205
        ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
                                        , tcdDataDefn = defn
                                        , tcdFVs = placeHolderNames }) }
206

207
cvtDec (NewtypeD ctxt tc tvs constr derivs)
208 209 210
  = do  { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
        ; con' <- cvtConstr constr
        ; derivs' <- cvtDerivs derivs
211 212 213
        ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
                                , dd_ctxt = ctxt'
                                , dd_kindSig = Nothing
214 215
                                , dd_cons = [con']
                                , dd_derivs = derivs' }
216
        ; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
217 218
                                    , tcdDataDefn = defn
                                    , tcdFVs = placeHolderNames }) }
219

220
cvtDec (ClassD ctxt cl tvs fds decs)
221 222
  = do  { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
        ; fds'  <- mapM cvt_fundep fds
223 224 225 226
        ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs (ptext (sLit "a class declaration")) decs
        ; unless (null adts')
            (failWith $ (ptext (sLit "Default data instance declarations are not allowed:"))
                   $$ (Outputable.ppr adts'))
227
        ; at_defs <- mapM cvt_at_def ats'
228
        ; returnJustL $ TyClD $
229
          ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
230
                    , tcdFDs = fds', tcdSigs = sigs', tcdMeths = binds'
231
                    , tcdATs = fams', tcdATDefs = at_defs, tcdDocs = []
232
                    , tcdFVs = placeHolderNames }
233
                              -- no docs in TH ^^
234
        }
235 236 237 238 239 240
  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
241

242
cvtDec (InstanceD ctxt ty decs)
243
  = do  { let doc = ptext (sLit "an instance declaration")
244
        ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs
245 246 247
        ; unless (null fams') (failWith (mkBadDecMsg doc fams'))
        ; ctxt' <- cvtContext ctxt
        ; L loc ty' <- cvtType ty
248
        ; let inst_ty' = L loc $ mkHsForAllTy Implicit [] ctxt' $ L loc ty'
249 250
        ; returnJustL $ InstD $ ClsInstD $
          ClsInstDecl inst_ty' binds' sigs' ats' adts' Nothing }
251

252
cvtDec (ForeignD ford)
253
  = do { ford' <- cvtForD ford
254
       ; returnJustL $ ForD ford' }
255

256
cvtDec (FamilyD flav tc tvs kind)
257
  = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
dreixel's avatar
dreixel committed
258
       ; kind' <- cvtMaybeKind kind
259 260
       ; returnJustL $ TyClD $ FamDecl $
         FamilyDecl (cvtFamFlavour flav) tc' tvs' kind' }
261
  where
262
    cvtFamFlavour TypeFam = OpenTypeFamily
263 264
    cvtFamFlavour DataFam = DataFamily

265
cvtDec (DataInstD ctxt tc tys constrs derivs)
266
  = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
267 268
       ; cons' <- mapM cvtConstr constrs
       ; derivs' <- cvtDerivs derivs
269 270 271 272
       ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
                               , dd_ctxt = ctxt'
                               , dd_kindSig = Nothing
                               , dd_cons = cons', dd_derivs = derivs' }
273

274
       ; returnJustL $ InstD $ DataFamInstD
275
           { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
276 277
                                         , dfid_defn = defn
                                         , dfid_fvs = placeHolderNames } }}
278

279
cvtDec (NewtypeInstD ctxt tc tys constr derivs)
280
  = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
281 282
       ; con' <- cvtConstr constr
       ; derivs' <- cvtDerivs derivs
283 284 285 286
       ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
                               , dd_ctxt = ctxt'
                               , dd_kindSig = Nothing
                               , dd_cons = [con'], dd_derivs = derivs' }
287
       ; returnJustL $ InstD $ DataFamInstD
288
           { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
289 290
                                         , dfid_defn = defn
                                         , dfid_fvs = placeHolderNames } }}
291

292
cvtDec (TySynInstD tc eqn)
293
  = do  { tc' <- tconNameL tc
294
        ; eqn' <- cvtTySynEqn tc' eqn
295
        ; returnJustL $ InstD $ TyFamInstD
296
            { tfid_inst = TyFamInstDecl { tfid_eqn = eqn'
297
                                        , tfid_fvs = placeHolderNames } } }
298 299 300 301 302

cvtDec (ClosedTypeFamilyD tc tyvars mkind eqns)
  = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tyvars
       ; mkind' <- cvtMaybeKind mkind
       ; eqns' <- mapM (cvtTySynEqn tc') eqns
303
       ; returnJustL $ TyClD $ FamDecl $
304
         FamilyDecl (ClosedTypeFamily (Just eqns')) tc' tvs' mkind' }
305 306 307 308

cvtDec (TH.RoleAnnotD tc roles)
  = do { tc' <- tconNameL tc
       ; let roles' = map (noLoc . cvtRole) roles
309
       ; returnJustL $ Hs.RoleAnnotD (RoleAnnotDecl tc' roles') }
310 311 312 313

cvtDec (TH.StandaloneDerivD cxt ty)
  = do { cxt' <- cvtContext cxt
       ; L loc ty'  <- cvtType ty
314
       ; let inst_ty' = L loc $ mkHsForAllTy Implicit [] cxt' $ L loc ty'
315 316
       ; returnJustL $ DerivD $
         DerivDecl { deriv_type = inst_ty', deriv_overlap_mode = Nothing } }
317 318 319 320 321

cvtDec (TH.DefaultSigD nm typ)
  = do { nm' <- vNameL nm
       ; ty' <- cvtType typ
       ; returnJustL $ Hs.SigD $ GenericSig [nm'] ty' }
322 323 324 325
----------------
cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName)
cvtTySynEqn tc (TySynEqn lhs rhs)
  = do  { lhs' <- mapM cvtType lhs
326
        ; rhs' <- cvtType rhs
327 328 329
        ; returnL $ TyFamEqn { tfe_tycon = tc
                             , tfe_pats = mkHsWithBndrs lhs'
                             , tfe_rhs = rhs' } }
330

331
----------------
332
cvt_ci_decs :: MsgDoc -> [TH.Dec]
333 334
            -> CvtM (LHsBinds RdrName,
                     [LSig RdrName],
335 336 337
                     [LFamilyDecl RdrName],
                     [LTyFamInstDecl RdrName],
                     [LDataFamInstDecl RdrName])
338 339 340
-- Convert the declarations inside a class or instance decl
-- ie signatures, bindings, and associated types
cvt_ci_decs doc decs
341
  = do  { decs' <- cvtDecs decs
342 343 344
        ; 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'
345
        ; let (binds', prob_fams')   = partitionWith is_bind prob_binds'
346
        ; let (fams', bads)          = partitionWith is_fam_decl prob_fams'
347
        ; unless (null bads) (failWith (mkBadDecMsg doc bads))
cactus's avatar
cactus committed
348 349
          --We use FromSource as the origin of the bind
          -- because the TH declaration is user-written
350
        ; return (listToBag binds', sigs', fams', ats', adts') }
351 352

----------------
353
cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
354 355
             -> CvtM ( LHsContext RdrName
                     , Located RdrName
356
                     , LHsTyVarBndrs RdrName)
357
cvt_tycl_hdr cxt tc tvs
358 359 360
  = do { cxt' <- cvtContext cxt
       ; tc'  <- tconNameL tc
       ; tvs' <- cvtTvs tvs
361
       ; return (cxt', tc', tvs')
362 363 364 365 366
       }

cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
               -> CvtM ( LHsContext RdrName
                       , Located RdrName
367
                       , HsWithBndrs RdrName [LHsType RdrName])
368 369 370 371
cvt_tyinst_hdr cxt tc tys
  = do { cxt' <- cvtContext cxt
       ; tc'  <- tconNameL tc
       ; tys' <- mapM cvtType tys
372
       ; return (cxt', tc', mkHsWithBndrs tys') }
373

374
-------------------------------------------------------------------
375
--              Partitioning declarations
376 377
-------------------------------------------------------------------

378 379
is_fam_decl :: LHsDecl RdrName -> Either (LFamilyDecl RdrName) (LHsDecl RdrName)
is_fam_decl (L loc (TyClD (FamDecl { tcdFam = d }))) = Left (L loc d)
380 381
is_fam_decl decl = Right decl

382 383 384 385 386 387 388
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
389 390 391 392 393 394 395

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)
396
is_bind decl                   = Right decl
397

398
mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc
399
mkBadDecMsg doc bads
400 401 402
  = sep [ ptext (sLit "Illegal declaration(s) in") <+> doc <> colon
        , nest 2 (vcat (map Outputable.ppr bads)) ]

403
---------------------------------------------------
404
--      Data types
405 406 407
-- Can't handle GADTs yet
---------------------------------------------------

408 409
cvtConstr :: TH.Con -> CvtM (LConDecl RdrName)

410
cvtConstr (NormalC c strtys)
411 412 413 414
  = do  { c'   <- cNameL c
        ; cxt' <- returnL []
        ; tys' <- mapM cvt_arg strtys
        ; returnL $ mkSimpleConDecl c' noExistentials cxt' (PrefixCon tys') }
415 416

cvtConstr (RecC c varstrtys)
417 418 419
  = do  { c'    <- cNameL c
        ; cxt'  <- returnL []
        ; args' <- mapM cvt_id_arg varstrtys
420
        ; returnL $ mkSimpleConDecl c' noExistentials cxt'
Alan Zimmerman's avatar
Alan Zimmerman committed
421
                                   (RecCon (noLoc args')) }
422 423

cvtConstr (InfixC st1 c st2)
424 425 426 427 428
  = do  { c' <- cNameL c
        ; cxt' <- returnL []
        ; st1' <- cvt_arg st1
        ; st2' <- cvt_arg st2
        ; returnL $ mkSimpleConDecl c' noExistentials cxt' (InfixCon st1' st2') }
429 430

cvtConstr (ForallC tvs ctxt con)
431 432 433 434
  = do  { tvs'  <- cvtTvs tvs
        ; L loc ctxt' <- cvtContext ctxt
        ; L _ con' <- cvtConstr con
        ; returnL $ con' { con_qvars = mkHsQTvs (hsQTvBndrs tvs' ++ hsQTvBndrs (con_qvars con'))
435
                         , con_cxt = L loc (ctxt' ++ (unLoc $ con_cxt con')) } }
436

437
cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
438
cvt_arg (NotStrict, ty) = cvtType ty
Alan Zimmerman's avatar
Alan Zimmerman committed
439 440 441 442 443 444
cvt_arg (IsStrict,  ty)
  = do { ty' <- cvtType ty
       ; returnL $ HsBangTy (HsSrcBang Nothing Nothing     True) ty' }
cvt_arg (Unpacked,  ty)
  = do { ty' <- cvtType ty
       ; returnL $ HsBangTy (HsSrcBang Nothing (Just True) True) ty' }
445

446
cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (LConDeclField RdrName)
447
cvt_id_arg (i, str, ty)
448 449
  = do  { i' <- vNameL i
        ; ty' <- cvt_arg (str,ty)
450 451 452
        ; return $ noLoc (ConDeclField { cd_fld_names = [i']
                                       , cd_fld_type =  ty'
                                       , cd_fld_doc = Nothing}) }
453

454
cvtDerivs :: [TH.Name] -> CvtM (Maybe (Located [LHsType RdrName]))
455 456
cvtDerivs [] = return Nothing
cvtDerivs cs = do { cs' <- mapM cvt_one cs
457
                  ; return (Just (noLoc cs')) }
458 459 460
        where
          cvt_one c = do { c' <- tconName c
                         ; returnL $ HsTyVar c' }
461

Alan Zimmerman's avatar
Alan Zimmerman committed
462 463 464 465
cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep (Located RdrName)))
cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs
                               ; ys' <- mapM tName ys
                               ; returnL (map noLoc xs', map noLoc ys') }
466

467
noExistentials :: [LHsTyVarBndr RdrName]
468 469 470
noExistentials = []

------------------------------------------
471
--      Foreign declarations
472 473 474 475
------------------------------------------

cvtForD :: Foreign -> CvtM (ForeignDecl RdrName)
cvtForD (ImportF callconv safety from nm ty)
476 477 478 479 480 481 482
  -- 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))
483 484
  | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety')
                                 (mkFastString (TH.nameBase nm))
Alan Zimmerman's avatar
Alan Zimmerman committed
485
                                 from (noLoc from)
486
  = mk_imp impspec
487
  | otherwise
488 489
  = failWith $ text (show from) <+> ptext (sLit "is not a valid ccall impent")
  where
490 491 492 493 494
    mk_imp impspec
      = do { nm' <- vNameL nm
           ; ty' <- cvtType ty
           ; return (ForeignImport nm' ty' noForeignImportCoercionYet impspec)
           }
495 496
    safety' = case safety of
                     Unsafe     -> PlayRisky
Ian Lynagh's avatar
Ian Lynagh committed
497
                     Safe       -> PlaySafe
498
                     Interruptible -> PlayInterruptible
499 500

cvtForD (ExportF callconv as nm ty)
501 502
  = do  { nm' <- vNameL nm
        ; ty' <- cvtType ty
503 504
        ; let e = CExport (noLoc (CExportStatic as
                                                (mkFastString as)
505
                                                (cvt_conv callconv)))
Alan Zimmerman's avatar
Alan Zimmerman committed
506
                                                (noLoc as)
507
        ; return $ ForeignExport nm' ty' noForeignExportCoercionYet e }
508

509
cvt_conv :: TH.Callconv -> CCallConv
510 511 512 513 514
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
515

516 517 518 519
------------------------------------------
--              Pragmas
------------------------------------------

520
cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl RdrName))
521 522 523
cvtPragmaD (InlineP nm inline rm phases)
  = do { nm' <- vNameL nm
       ; let dflt = dfltActivation inline
Alan Zimmerman's avatar
Alan Zimmerman committed
524 525
       ; let ip   = InlinePragma { inl_src    = "{-# INLINE"
                                 , inl_inline = cvtInline inline
526 527 528
                                 , inl_rule   = cvtRuleMatch rm
                                 , inl_act    = cvtPhases phases dflt
                                 , inl_sat    = Nothing }
529
       ; returnJustL $ Hs.SigD $ InlineSig nm' ip }
530 531

cvtPragmaD (SpecialiseP nm ty inline phases)
532 533
  = do { nm' <- vNameL nm
       ; ty' <- cvtType ty
534 535 536
       ; let (inline', dflt) = case inline of
               Just inline1 -> (cvtInline inline1, dfltActivation inline1)
               Nothing      -> (EmptyInlineSpec,   AlwaysActive)
Alan Zimmerman's avatar
Alan Zimmerman committed
537 538
       ; let ip = InlinePragma { inl_src    = "{-# INLINE"
                               , inl_inline = inline'
539 540 541
                               , inl_rule   = Hs.FunLike
                               , inl_act    = cvtPhases phases dflt
                               , inl_sat    = Nothing }
542
       ; returnJustL $ Hs.SigD $ SpecSig nm' [ty'] ip }
543 544 545

cvtPragmaD (SpecialiseInstP ty)
  = do { ty' <- cvtType ty
Alan Zimmerman's avatar
Alan Zimmerman committed
546
       ; returnJustL $ Hs.SigD $ SpecInstSig "{-# SPECIALISE" ty' }
547 548 549 550 551 552 553

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
554
       ; returnJustL $ Hs.RuleD
555
            $ HsRules "{-# RULES" [noLoc $ HsRule (noLoc (nm,nm')) act bndrs'
Alan Zimmerman's avatar
Alan Zimmerman committed
556 557
                                                  lhs' placeHolderNames
                                                  rhs' placeHolderNames]
558
       }
559

560 561 562 563 564 565
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
566
           return (TypeAnnProvenance  (noLoc n'))
567
         ValueAnnotation n -> do
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
568
           n' <- vcName n
Alan Zimmerman's avatar
Alan Zimmerman committed
569 570
           return (ValueAnnProvenance (noLoc n'))
       ; returnJustL $ Hs.AnnD $ HsAnnotation "{-# ANN" target' exp'
571 572 573 574 575
       }

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

578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595
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
cvtPhases (FromPhase i)   _    = ActiveAfter i
cvtPhases (BeforePhase i) _    = ActiveBefore i

596
cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr RdrName)
597 598
cvtRuleBndr (RuleVar n)
  = do { n' <- vNameL n
599
       ; return $ noLoc $ Hs.RuleBndr n' }
600 601 602
cvtRuleBndr (TypedRuleVar n ty)
  = do { n'  <- vNameL n
       ; ty' <- cvtType ty
603
       ; return $ noLoc $ Hs.RuleBndrSig n' $ mkHsWithBndrs ty' }
604

605
---------------------------------------------------
606
--              Declarations
607
---------------------------------------------------
608

609
cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds RdrName)
610
cvtLocalDecs doc ds
611 612
  | null ds
  = return EmptyLocalBinds
613
  | otherwise
614
  = do { ds' <- cvtDecs ds
615 616 617
       ; let (binds, prob_sigs) = partitionWith is_bind ds'
       ; let (sigs, bads) = partitionWith is_sig prob_sigs
       ; unless (null bads) (failWith (mkBadDecMsg doc bads))
618
       ; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) }
619

620
cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName))
621
cvtClause (Clause ps body wheres)
622 623 624
  = do  { ps' <- cvtPats ps
        ; g'  <- cvtGuard body
        ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) wheres
625
        ; returnL $ Hs.Match Nothing ps' Nothing (GRHSs g' ds') }
626 627


628
-------------------------------------------------------------------
629
--              Expressions
630
-------------------------------------------------------------------
631

632 633 634
cvtl :: TH.Exp -> CvtM (LHsExpr RdrName)
cvtl e = wrapL (cvt e)
  where
635 636
    cvt (VarE s)        = do { s' <- vName s; return $ HsVar s' }
    cvt (ConE s)        = do { s' <- cName s; return $ HsVar s' }
637
    cvt (LitE l)
638
      | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }
639
      | otherwise       = do { l' <- cvtLit l;     return $ HsLit l' }
640

641
    cvt (AppE x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' }
642
    cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e
643
                            ; return $ HsLam (mkMatchGroup FromSource [mkSimpleMatch ps' e']) }
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
644
    cvt (LamCaseE ms)  = do { ms' <- mapM cvtMatch ms
645
                            ; return $ HsLamCase placeHolderType
646
                                                 (mkMatchGroup FromSource ms')
647
                            }
648
    cvt (TupE [e])     = do { e' <- cvtl e; return $ HsPar e' }
649
                                 -- Note [Dropping constructors]
650
                                 -- Singleton tuples treated like nothing (just parens)
651 652 653 654 655 656
    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 }
657
    cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
658
                            ; return $ HsIf (Just noSyntaxExpr) x' y' z' }
659 660 661 662
    cvt (MultiIfE alts)
      | null alts      = failWith (ptext (sLit "Multi-way if-expression with no alternatives"))
      | otherwise      = do { alts' <- mapM cvtpair alts
                            ; return $ HsMultiIf placeHolderType alts' }
663
    cvt (LetE ds e)    = do { ds' <- cvtLocalDecs (ptext (sLit "a let expression")) ds
664
                            ; e' <- cvtl e; return $ HsLet ds' e' }
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
665
    cvt (CaseE e ms)   = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
666
                            ; return $ HsCase e' (mkMatchGroup FromSource ms') }
667 668
    cvt (DoE ss)       = cvtHsDo DoExpr ss
    cvt (CompE ss)     = cvtHsDo ListComp ss
669
    cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr Nothing dd' }
670
    cvt (ListE xs)
671
      | Just s <- allCharLs xs       = do { l' <- cvtLit (StringL s); return (HsLit l') }
672
             -- Note [Converting strings]
673 674 675
      | otherwise       = do { xs' <- mapM cvtl xs
                             ; return $ ExplicitList placeHolderType Nothing xs'
                             }
676 677

    -- Infix expressions
678
    cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
679
                                          ; wrapParL HsPar $
680
                                            OpApp (mkLHsPar x') s' undefined (mkLHsPar y') }
681 682 683 684
                                            -- Parenthesise both arguments and result,
                                            -- to ensure this operator application does
                                            -- does not get re-associated
                            -- See Note [Operator association]
685
    cvt (InfixE Nothing  s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
686 687
                                          ; wrapParL HsPar $ SectionR s' y' }
                                            -- See Note [Sections in HsSyn] in HsExpr
688
    cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
689
                                          ; wrapParL HsPar $ SectionL x' s' }
690

691 692 693
    cvt (InfixE Nothing  s Nothing ) = do { s' <- cvtl s; return $ HsPar s' }
                                       -- Can I indicate this is an infix thing?
                                       -- Note [Dropping constructors]
694

695
    cvt (UInfixE x s y)  = do { x' <- cvtl x
696
                              ; let x'' = case x' of
697 698 699
                                            L _ (OpApp {}) -> x'
                                            _ -> mkLHsPar x'
                              ; cvtOpApp x'' s y } --  Note [Converting UInfix]
700

701
    cvt (ParensE e)      = do { e' <- cvtl e; return $ HsPar e' }
702
    cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtType t
thomasw's avatar
thomasw committed
703
                              ; return $ ExprWithTySig e' t' PlaceHolder }
704
    cvt (RecConE c flds) = do { c' <- cNameL c
705 706
                              ; flds' <- mapM cvtFld flds
                              ; return $ RecordCon c' noPostTcExpr (HsRecFields flds' Nothing)}
707
    cvt (RecUpdE e flds) = do { e' <- cvtl e
708 709
                              ; flds' <- mapM cvtFld flds
                              ; return $ RecordUpd e' (HsRecFields flds' Nothing) [] [] [] }
710
    cvt (StaticE e)      = fmap HsStatic $ cvtl e
711

712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727
{- Note [Dropping constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When we drop constructors from the input (for instance, when we encounter @TupE [e]@)
we must insert parentheses around the argument. Otherwise, @UInfix@ constructors in @e@
could meet @UInfix@ constructors containing the @TupE [e]@. For example:

  UInfixE x * (TupE [UInfixE y + z])

If we drop the singleton tuple but don't insert parentheses, the @UInfixE@s would meet
and the above expression would be reassociated to

  OpApp (OpApp x * y) + z

which we don't want.
-}

728
cvtFld :: (TH.Name, TH.Exp) -> CvtM (LHsRecField RdrName (LHsExpr RdrName))
729
cvtFld (v,e)
730
  = do  { v' <- vNameL v; e' <- cvtl e
731 732
        ; return (noLoc $ HsRecField { hsRecFieldId = v', hsRecFieldArg = e'
                                     , hsRecPun = False}) }
733 734

cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)
735
cvtDD (FromR x)           = do { x' <- cvtl x; return $ From x' }
736 737 738 739
cvtDD (FromThenR x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }
cvtDD (FromToR x y)       = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }
cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }

740 741 742 743 744 745 746 747 748 749
{- Note [Operator assocation]
We must be quite careful about adding parens:
  * Infix (UInfix ...) op arg      Needs parens round the first arg
  * Infix (Infix ...) op arg       Needs parens round the first arg
  * UInfix (UInfix ...) op arg     No parens for first arg
  * UInfix (Infix ...) op arg      Needs parens round first arg


Note [Converting UInfix]
~~~~~~~~~~~~~~~~~~~~~~~~
750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799
When converting @UInfixE@ and @UInfixP@ values, we want to readjust
the trees to reflect the fixities of the underlying operators:

  UInfixE x * (UInfixE y + z) ---> (x * y) + z

This is done by the renamer (see @mkOppAppRn@ and @mkConOppPatRn@ in
RnTypes), which expects that the input will be completely left-biased.
So we left-bias the trees  of @UInfixP@ and @UInfixE@ that we come across.

Sample input:

  UInfixE
   (UInfixE x op1 y)
   op2
   (UInfixE z op3 w)

Sample output:

  OpApp
    (OpApp
      (OpApp x op1 y)
      op2
      z)
    op3
    w

The functions @cvtOpApp@ and @cvtOpAppP@ are responsible for this
left-biasing.
-}

{- | @cvtOpApp x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.
The produced tree of infix expressions will be left-biased, provided @x@ is.

We can see that @cvtOpApp@ is correct as follows. The inductive hypothesis
is that @cvtOpApp x op y@ is left-biased, provided @x@ is. It is clear that
this holds for both branches (of @cvtOpApp@), provided we assume it holds for
the recursive calls to @cvtOpApp@.

When we call @cvtOpApp@ from @cvtl@, the first argument will always be left-biased
since we have already run @cvtl@ on it.
-}
cvtOpApp :: LHsExpr RdrName -> TH.Exp -> TH.Exp -> CvtM (HsExpr RdrName)
cvtOpApp x op1 (UInfixE y op2 z)
  = do { l <- wrapL $ cvtOpApp x op1 y
       ; cvtOpApp l op2 z }
cvtOpApp x op y
  = do { op' <- cvtl op
       ; y' <- cvtl y
       ; return (OpApp x op' undefined y') }

800
-------------------------------------
801
--      Do notation and statements
802 803
-------------------------------------

804
cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr RdrName)
805
cvtHsDo do_or_lc stmts
806 807
  | null stmts = failWith (ptext (sLit "Empty stmt list in do-block"))
  | otherwise
808
  = do  { stmts' <- cvtStmts stmts
809
        ; let Just (stmts'', last') = snocView stmts'
810

811 812 813
        ; last'' <- case last' of
                    L loc (BodyStmt body _ _ _) -> return (L loc (mkLastStmt body))
                    _ -> failWith (bad_last last')
814

815
        ; return $ HsDo do_or_lc (stmts'' ++ [last'']) placeHolderType }
816
  where
817
    bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprAStmtContext do_or_lc <> colon
818
                         , nest 2 $ Outputable.ppr stmt
819
                         , ptext (sLit "(It should be an expression.)") ]
820

821
cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName (LHsExpr RdrName)]
822
cvtStmts = mapM cvtStmt
823

824 825
cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName (LHsExpr RdrName))
cvtStmt (NoBindS e)    = do { e' <- cvtl e; returnL $ mkBodyStmt e' }
826
cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
827
cvtStmt (TH.LetS ds)   = do { ds' <- cvtLocalDecs (ptext (sLit "a let binding")) ds
828
                            ; returnL $ LetStmt ds' }
829
cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noSyntaxExpr noSyntaxExpr }
830 831
                       where
                         cvt_one ds = do { ds' <- cvtStmts ds; return (ParStmtBlock ds' undefined noSyntaxExpr) }
832

833
cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName))
834
cvtMatch (TH.Match p body decs)
835 836 837
  = do  { p' <- cvtPat p
        ; g' <- cvtGuard body
        ; decs' <- cvtLocalDecs (ptext (sLit "a where clause")) decs
838
        ; returnL $ Hs.Match Nothing [p'] Nothing (GRHSs g' decs') }
839

840
cvtGuard :: TH.Body -> CvtM [LGRHS RdrName (LHsExpr RdrName)]
841 842 843
cvtGuard (GuardedB pairs) = mapM cvtpair pairs
cvtGuard (NormalB e)      = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] }

844
cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName (LHsExpr RdrName))
845
cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
846 847
                              ; g' <- returnL $ mkBodyStmt ge'
                              ; returnL $ GRHS [g'] rhs' }
848
cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
849
                              ; returnL $ GRHS gs' rhs' }
850 851

cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
852
cvtOverLit (IntegerL i)
Alan Zimmerman's avatar
Alan Zimmerman committed
853
  = do { force i; return $ mkHsIntegral (show i) i placeHolderType}
854
cvtOverLit (RationalL r)
855
  = do { force r; return $ mkHsFractional (cvtFractionalLit r) placeHolderType}
856
cvtOverLit (StringL s)
857 858
  = do { let { s' = mkFastString s }
       ; force s'
Alan Zimmerman's avatar
Alan Zimmerman committed
859
       ; return $ mkHsIsString s s' placeHolderType
860 861 862
       }
cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
-- An Integer is like an (overloaded) '3' in a Haskell source program
863
-- Similarly 3.5 for fractionals
864

865
{- Note [Converting strings]
866 867
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to