Convert.lhs 48.7 KB
Newer Older
1
%
2
% (c) The University of Glasgow 2006
3 4 5 6 7 8
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%

This module converts Template Haskell syntax into HsSyn

\begin{code}
9 10
{-# LANGUAGE MagicHash #-}

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 Util
34
import FastString
35 36
import Outputable

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

41 42 43
import Language.Haskell.TH as TH hiding (sigP)
import Language.Haskell.TH.Syntax as TH
import GHC.Exts
44 45

-------------------------------------------------------------------
46
--              The external interface
47

48
convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl RdrName]
49 50 51
convertToHsDecls loc ds = initCvt loc (mapM cvt_dec ds)
  where
    cvt_dec d = wrapMsg "declaration" d (cvtDec d)
52

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

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

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

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

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

75 76 77
-- 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
78

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

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

86
instance Monad CvtM where
87
  return x       = CvtM $ \_   -> Right x
88
  (CvtM m) >>= k = CvtM $ \loc -> case m loc of
89 90
                                  Left err -> Left err
                                  Right v  -> unCvtM (k v) loc
91

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

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

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

101 102 103
getL :: CvtM SrcSpan
getL = CvtM (\loc -> Right loc)

104 105 106
returnL :: a -> CvtM (Located a)
returnL x = CvtM (\loc -> Right (L loc x))

107 108 109
wrapParL :: (Located a -> a) -> a -> CvtM a
wrapParL add_par x = CvtM (\loc -> Right (add_par (L loc x)))

110 111 112 113 114 115 116
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
117 118
        -- Show the item in pretty syntax normally,
        -- but with all its constructors if you say -dppr-debug
119
    msg sty = hang (ptext (sLit "When splicing a TH") <+> text what <> colon)
120
                 2 (if debugStyle sty
121 122 123
                    then text (show item)
                    else text (pprint item))

124 125
wrapL :: CvtM a -> CvtM (Located a)
wrapL (CvtM m) = CvtM (\loc -> case m loc of
126 127
                               Left err -> Left err
                               Right v  -> Right (L loc v))
128 129

-------------------------------------------------------------------
130
cvtDec :: TH.Dec -> CvtM (LHsDecl RdrName)
131
cvtDec (TH.ValD pat body ds)
132
  | TH.VarP s <- pat
133 134 135
  = do  { s' <- vNameL s
        ; cl' <- cvtClause (Clause [] body ds)
        ; returnL $ Hs.ValD $ mkFunBind s' [cl'] }
136

137
  | otherwise
138 139 140 141
  = do  { pat' <- cvtPat pat
        ; body' <- cvtGuard body
        ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) ds
        ; returnL $ Hs.ValD $
142
          PatBind { pat_lhs = pat', pat_rhs = GRHSs body' ds'
143
                  , pat_rhs_ty = placeHolderType, bind_fvs = placeHolderNames
144
                  , pat_ticks = (Nothing,[]) } }
145

146
cvtDec (TH.FunD nm cls)
147 148
  | null cls
  = failWith (ptext (sLit "Function binding for")
149 150
                 <+> quotes (text (TH.pprint nm))
                 <+> ptext (sLit "has no equations"))
151
  | otherwise
152 153 154
  = do  { nm' <- vNameL nm
        ; cls' <- mapM cvtClause cls
        ; returnL $ Hs.ValD $ mkFunBind nm' cls' }
155

156
cvtDec (TH.SigD nm typ)
157
  = do  { nm' <- vNameL nm
158 159
        ; ty' <- cvtType typ
        ; returnL $ Hs.SigD (TypeSig [nm'] ty') }
160

161 162
cvtDec (TH.InfixD fx nm)
  = do { nm' <- vNameL nm
163
       ; returnL (Hs.SigD (FixSig (FixitySig nm' (cvtFixity fx)))) }
164

165
cvtDec (PragmaD prag)
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
166
  = cvtPragmaD prag
167 168

cvtDec (TySynD tc tvs rhs)
169 170
  = do  { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
        ; rhs' <- cvtType rhs
171
        ; returnL $ TyClD (SynDecl { tcdLName = tc'
172
                                  , tcdTyVars = tvs', tcdFVs = placeHolderNames
173
                                  , tcdRhs = rhs' }) }
174

175
cvtDec (DataD ctxt tc tvs constrs derivs)
176 177 178
  = do  { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
        ; cons' <- mapM cvtConstr constrs
        ; derivs' <- cvtDerivs derivs
179 180 181 182 183
        ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
                                , dd_ctxt = ctxt'
                                , dd_kindSig = Nothing
                                , dd_cons = cons', dd_derivs = derivs' }
        ; returnL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
184 185
                                    , tcdDataDefn = defn
                                    , tcdFVs = placeHolderNames }) }
186

187
cvtDec (NewtypeD ctxt tc tvs constr derivs)
188 189 190
  = do  { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
        ; con' <- cvtConstr constr
        ; derivs' <- cvtDerivs derivs
191 192 193 194 195
        ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
                                , dd_ctxt = ctxt'
                                , dd_kindSig = Nothing
                                , dd_cons = [con'], dd_derivs = derivs' }
        ; returnL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
196 197
                                    , tcdDataDefn = defn
                                    , tcdFVs = placeHolderNames }) }
198

199
cvtDec (ClassD ctxt cl tvs fds decs)
200 201
  = do  { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
        ; fds'  <- mapM cvt_fundep fds
202 203 204 205
        ; (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'))
206
        ; at_defs <- mapM cvt_at_def ats'
207
        ; returnL $ TyClD $
208
          ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
209
                    , tcdFDs = fds', tcdSigs = sigs', tcdMeths = binds'
210
                    , tcdATs = fams', tcdATDefs = at_defs, tcdDocs = []
211
                    , tcdFVs = placeHolderNames }
212
                              -- no docs in TH ^^
213
        }
214 215 216 217 218 219
  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
220

221
cvtDec (InstanceD ctxt ty decs)
222
  = do  { let doc = ptext (sLit "an instance declaration")
223
        ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs
224 225 226 227
        ; unless (null fams') (failWith (mkBadDecMsg doc fams'))
        ; ctxt' <- cvtContext ctxt
        ; L loc ty' <- cvtType ty
        ; let inst_ty' = L loc $ mkImplicitHsForAllTy ctxt' $ L loc ty'
228
        ; returnL $ InstD (ClsInstD (ClsInstDecl inst_ty' binds' sigs' ats' adts' Nothing)) }
229

230
cvtDec (ForeignD ford)
231
  = do { ford' <- cvtForD ford
232
       ; returnL $ ForD ford' }
233

234
cvtDec (FamilyD flav tc tvs kind)
235
  = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
dreixel's avatar
dreixel committed
236
       ; kind' <- cvtMaybeKind kind
237
       ; returnL $ TyClD (FamDecl (FamilyDecl (cvtFamFlavour flav) tc' tvs' kind')) }
238
  where
239
    cvtFamFlavour TypeFam = OpenTypeFamily
240 241
    cvtFamFlavour DataFam = DataFamily

242
cvtDec (DataInstD ctxt tc tys constrs derivs)
243
  = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
244 245
       ; cons' <- mapM cvtConstr constrs
       ; derivs' <- cvtDerivs derivs
246 247 248 249
       ; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
                               , dd_ctxt = ctxt'
                               , dd_kindSig = Nothing
                               , dd_cons = cons', dd_derivs = derivs' }
250

251 252
       ; returnL $ InstD $ DataFamInstD
           { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
253 254
                                         , dfid_defn = defn
                                         , dfid_fvs = placeHolderNames } }}
255

256
cvtDec (NewtypeInstD ctxt tc tys constr derivs)
257
  = do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
258 259
       ; con' <- cvtConstr constr
       ; derivs' <- cvtDerivs derivs
260 261 262 263 264 265
       ; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
                               , dd_ctxt = ctxt'
                               , dd_kindSig = Nothing
                               , dd_cons = [con'], dd_derivs = derivs' }
       ; returnL $ InstD $ DataFamInstD
           { dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
266 267
                                         , dfid_defn = defn
                                         , dfid_fvs = placeHolderNames } }}
268

269
cvtDec (TySynInstD tc eqn)
270
  = do  { tc' <- tconNameL tc
271
        ; eqn' <- cvtTySynEqn tc' eqn
272
        ; returnL $ InstD $ TyFamInstD
273
            { tfid_inst = TyFamInstDecl { tfid_eqn = eqn'
274
                                        , tfid_fvs = placeHolderNames } } }
275 276

cvtDec (ClosedTypeFamilyD tc tyvars mkind eqns)
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
277
  | not $ null eqns
278 279 280 281
  = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tyvars
       ; mkind' <- cvtMaybeKind mkind
       ; eqns' <- mapM (cvtTySynEqn tc') eqns
       ; returnL $ TyClD (FamDecl (FamilyDecl (ClosedTypeFamily eqns') tc' tvs' mkind')) }
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
282 283
  | otherwise
  = failWith (ptext (sLit "Illegal empty closed type family"))
284 285 286 287

cvtDec (TH.RoleAnnotD tc roles)
  = do { tc' <- tconNameL tc
       ; let roles' = map (noLoc . cvtRole) roles
288
       ; returnL $ Hs.RoleAnnotD (RoleAnnotDecl tc' roles') }
289 290 291 292
----------------
cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName)
cvtTySynEqn tc (TySynEqn lhs rhs)
  = do  { lhs' <- mapM cvtType lhs
293
        ; rhs' <- cvtType rhs
294 295 296
        ; returnL $ TyFamEqn { tfe_tycon = tc
                             , tfe_pats = mkHsWithBndrs lhs'
                             , tfe_rhs = rhs' } }
297

298
----------------
299
cvt_ci_decs :: MsgDoc -> [TH.Dec]
300 301
            -> CvtM (LHsBinds RdrName,
                     [LSig RdrName],
302 303 304
                     [LFamilyDecl RdrName],
                     [LTyFamInstDecl RdrName],
                     [LDataFamInstDecl RdrName])
305 306 307 308
-- Convert the declarations inside a class or instance decl
-- ie signatures, bindings, and associated types
cvt_ci_decs doc decs
  = do  { decs' <- mapM cvtDec decs
309 310 311
        ; 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'
312
        ; let (binds', prob_fams')   = partitionWith is_bind prob_binds'
313
        ; let (fams', bads)          = partitionWith is_fam_decl prob_fams'
314
        ; unless (null bads) (failWith (mkBadDecMsg doc bads))
Gergő Érdi's avatar
Gergő Érdi committed
315 316
          --We use FromSource as the origin of the bind
          -- because the TH declaration is user-written
317
        ; return (listToBag binds', sigs', fams', ats', adts') }
318 319

----------------
320
cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
321 322
             -> CvtM ( LHsContext RdrName
                     , Located RdrName
323
                     , LHsTyVarBndrs RdrName)
324
cvt_tycl_hdr cxt tc tvs
325 326 327
  = do { cxt' <- cvtContext cxt
       ; tc'  <- tconNameL tc
       ; tvs' <- cvtTvs tvs
328
       ; return (cxt', tc', tvs')
329 330 331 332 333
       }

cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
               -> CvtM ( LHsContext RdrName
                       , Located RdrName
334
                       , HsWithBndrs RdrName [LHsType RdrName])
335 336 337 338
cvt_tyinst_hdr cxt tc tys
  = do { cxt' <- cvtContext cxt
       ; tc'  <- tconNameL tc
       ; tys' <- mapM cvtType tys
339
       ; return (cxt', tc', mkHsWithBndrs tys') }
340

341
-------------------------------------------------------------------
342
--              Partitioning declarations
343 344
-------------------------------------------------------------------

345 346
is_fam_decl :: LHsDecl RdrName -> Either (LFamilyDecl RdrName) (LHsDecl RdrName)
is_fam_decl (L loc (TyClD (FamDecl { tcdFam = d }))) = Left (L loc d)
347 348
is_fam_decl decl = Right decl

349 350 351 352 353 354 355
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
356 357 358 359 360 361 362

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)
363
is_bind decl                   = Right decl
364

365
mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc
366
mkBadDecMsg doc bads
367 368 369
  = sep [ ptext (sLit "Illegal declaration(s) in") <+> doc <> colon
        , nest 2 (vcat (map Outputable.ppr bads)) ]

370
---------------------------------------------------
371
--      Data types
372 373 374
-- Can't handle GADTs yet
---------------------------------------------------

375 376
cvtConstr :: TH.Con -> CvtM (LConDecl RdrName)

377
cvtConstr (NormalC c strtys)
378 379 380 381
  = do  { c'   <- cNameL c
        ; cxt' <- returnL []
        ; tys' <- mapM cvt_arg strtys
        ; returnL $ mkSimpleConDecl c' noExistentials cxt' (PrefixCon tys') }
382 383

cvtConstr (RecC c varstrtys)
384 385 386 387
  = do  { c'    <- cNameL c
        ; cxt'  <- returnL []
        ; args' <- mapM cvt_id_arg varstrtys
        ; returnL $ mkSimpleConDecl c' noExistentials cxt' (RecCon args') }
388 389

cvtConstr (InfixC st1 c st2)
390 391 392 393 394
  = do  { c' <- cNameL c
        ; cxt' <- returnL []
        ; st1' <- cvt_arg st1
        ; st2' <- cvt_arg st2
        ; returnL $ mkSimpleConDecl c' noExistentials cxt' (InfixCon st1' st2') }
395 396

cvtConstr (ForallC tvs ctxt con)
397 398 399 400
  = do  { tvs'  <- cvtTvs tvs
        ; L loc ctxt' <- cvtContext ctxt
        ; L _ con' <- cvtConstr con
        ; returnL $ con' { con_qvars = mkHsQTvs (hsQTvBndrs tvs' ++ hsQTvBndrs (con_qvars con'))
401
                         , con_cxt = L loc (ctxt' ++ (unLoc $ con_cxt con')) } }
402

403
cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
404
cvt_arg (NotStrict, ty) = cvtType ty
405 406
cvt_arg (IsStrict,  ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsUserBang Nothing     True) ty' }
cvt_arg (Unpacked,  ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsUserBang (Just True) True) ty' }
407

408
cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (ConDeclField RdrName)
409
cvt_id_arg (i, str, ty)
410 411 412
  = do  { i' <- vNameL i
        ; ty' <- cvt_arg (str,ty)
        ; return (ConDeclField { cd_fld_name = i', cd_fld_type =  ty', cd_fld_doc = Nothing}) }
413

414
cvtDerivs :: [TH.Name] -> CvtM (Maybe [LHsType RdrName])
415 416
cvtDerivs [] = return Nothing
cvtDerivs cs = do { cs' <- mapM cvt_one cs
417 418 419 420
                  ; return (Just cs') }
        where
          cvt_one c = do { c' <- tconName c
                         ; returnL $ HsTyVar c' }
421 422 423 424

cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep RdrName))
cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs; ys' <- mapM tName ys; returnL (xs', ys') }

425
noExistentials :: [LHsTyVarBndr RdrName]
426 427 428
noExistentials = []

------------------------------------------
429
--      Foreign declarations
430 431 432 433
------------------------------------------

cvtForD :: Foreign -> CvtM (ForeignDecl RdrName)
cvtForD (ImportF callconv safety from nm ty)
434
  | Just impspec <- parseCImport (cvt_conv callconv) safety'
435 436 437
                                 (mkFastString (TH.nameBase nm)) from
  = do { nm' <- vNameL nm
       ; ty' <- cvtType ty
438
       ; return (ForeignImport nm' ty' noForeignImportCoercionYet impspec)
439
       }
440
  | otherwise
441 442
  = failWith $ text (show from) <+> ptext (sLit "is not a valid ccall impent")
  where
443 444
    safety' = case safety of
                     Unsafe     -> PlayRisky
Ian Lynagh's avatar
Ian Lynagh committed
445
                     Safe       -> PlaySafe
446
                     Interruptible -> PlayInterruptible
447 448

cvtForD (ExportF callconv as nm ty)
449 450 451 452
  = do  { nm' <- vNameL nm
        ; ty' <- cvtType ty
        ; let e = CExport (CExportStatic (mkFastString as) (cvt_conv callconv))
        ; return $ ForeignExport nm' ty' noForeignExportCoercionYet e }
453

454
cvt_conv :: TH.Callconv -> CCallConv
455 456
cvt_conv TH.CCall   = CCallConv
cvt_conv TH.StdCall = StdCallConv
457

458 459 460 461
------------------------------------------
--              Pragmas
------------------------------------------

mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
462 463 464 465 466 467 468 469 470 471 472
cvtPragmaD :: Pragma -> CvtM (LHsDecl RdrName)
cvtPragmaD (InlineP nm inline rm phases)
  = do { nm' <- vNameL nm
       ; let dflt = dfltActivation inline
       ; let ip   = InlinePragma { inl_inline = cvtInline inline
                                 , inl_rule   = cvtRuleMatch rm
                                 , inl_act    = cvtPhases phases dflt
                                 , inl_sat    = Nothing }
       ; returnL $ Hs.SigD $ InlineSig nm' ip }

cvtPragmaD (SpecialiseP nm ty inline phases)
473 474
  = do { nm' <- vNameL nm
       ; ty' <- cvtType ty
mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497
       ; let (inline', dflt) = case inline of
               Just inline1 -> (cvtInline inline1, dfltActivation inline1)
               Nothing      -> (EmptyInlineSpec,   AlwaysActive)
       ; let ip = InlinePragma { inl_inline = inline'
                               , inl_rule   = Hs.FunLike
                               , inl_act    = cvtPhases phases dflt
                               , inl_sat    = Nothing }
       ; returnL $ Hs.SigD $ SpecSig nm' ty' ip }

cvtPragmaD (SpecialiseInstP ty)
  = do { ty' <- cvtType ty
       ; returnL $ Hs.SigD $ SpecInstSig ty' }

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
       ; returnL $ Hs.RuleD $ HsRule nm' act bndrs'
                                     lhs' placeHolderNames
                                     rhs' placeHolderNames
       }
498

499 500 501 502 503 504 505 506 507 508 509 510 511
cvtPragmaD (AnnP target exp)
  = do { exp' <- cvtl exp
       ; target' <- case target of
         ModuleAnnotation  -> return ModuleAnnProvenance
         TypeAnnotation n  -> do
           n' <- tconName n
           return (TypeAnnProvenance  n')
         ValueAnnotation n -> do
           n' <- if isVarName n then vName n else cName n
           return (ValueAnnProvenance n')
       ; returnL $ Hs.AnnD $ HsAnnotation target' exp'
       }

mikhail.vorozhtsov's avatar
mikhail.vorozhtsov committed
512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537
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

cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.RuleBndr RdrName)
cvtRuleBndr (RuleVar n)
  = do { n' <- vNameL n
       ; return $ Hs.RuleBndr n' }
cvtRuleBndr (TypedRuleVar n ty)
  = do { n'  <- vNameL n
       ; ty' <- cvtType ty
       ; return $ Hs.RuleBndrSig n' $ mkHsWithBndrs ty' }
538

539
---------------------------------------------------
540
--              Declarations
541
---------------------------------------------------
542

543
cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds RdrName)
544
cvtLocalDecs doc ds
545 546
  | null ds
  = return EmptyLocalBinds
547
  | otherwise
548 549 550 551
  = do { ds' <- mapM cvtDec ds
       ; let (binds, prob_sigs) = partitionWith is_bind ds'
       ; let (sigs, bads) = partitionWith is_sig prob_sigs
       ; unless (null bads) (failWith (mkBadDecMsg doc bads))
552
       ; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) }
553

554
cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName))
555
cvtClause (Clause ps body wheres)
556 557 558 559
  = do  { ps' <- cvtPats ps
        ; g'  <- cvtGuard body
        ; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) wheres
        ; returnL $ Hs.Match ps' Nothing (GRHSs g' ds') }
560 561


562
-------------------------------------------------------------------
563
--              Expressions
564
-------------------------------------------------------------------
565

566 567 568
cvtl :: TH.Exp -> CvtM (LHsExpr RdrName)
cvtl e = wrapL (cvt e)
  where
569 570
    cvt (VarE s)        = do { s' <- vName s; return $ HsVar s' }
    cvt (ConE s)        = do { s' <- cName s; return $ HsVar s' }
571
    cvt (LitE l)
572
      | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }
573
      | otherwise       = do { l' <- cvtLit l;     return $ HsLit l' }
574

575
    cvt (AppE x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' }
576
    cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e
577
                            ; return $ HsLam (mkMatchGroup FromSource [mkSimpleMatch ps' e']) }
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
578
    cvt (LamCaseE ms)  = do { ms' <- mapM cvtMatch ms
579
                            ; return $ HsLamCase placeHolderType
580
                                                 (mkMatchGroup FromSource ms')
581
                            }
582
    cvt (TupE [e])     = do { e' <- cvtl e; return $ HsPar e' }
583
                                 -- Note [Dropping constructors]
584
                                 -- Singleton tuples treated like nothing (just parens)
585
    cvt (TupE es)      = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Boxed }
586
    cvt (UnboxedTupE es)      = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Unboxed }
587
    cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
588
                            ; return $ HsIf (Just noSyntaxExpr) x' y' z' }
589 590 591 592
    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' }
593 594
    cvt (LetE ds e)    = do { ds' <- cvtLocalDecs (ptext (sLit "a let expression")) ds
                            ; e' <- cvtl e; return $ HsLet ds' e' }
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
595
    cvt (CaseE e ms)   = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
596
                            ; return $ HsCase e' (mkMatchGroup FromSource ms') }
597 598
    cvt (DoE ss)       = cvtHsDo DoExpr ss
    cvt (CompE ss)     = cvtHsDo ListComp ss
599
    cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr Nothing dd' }
600
    cvt (ListE xs)
601
      | Just s <- allCharLs xs       = do { l' <- cvtLit (StringL s); return (HsLit l') }
602
             -- Note [Converting strings]
603 604 605
      | otherwise       = do { xs' <- mapM cvtl xs
                             ; return $ ExplicitList placeHolderType Nothing xs'
                             }
606 607

    -- Infix expressions
608
    cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
609
                                          ; wrapParL HsPar $
610
                                            OpApp (mkLHsPar x') s' undefined (mkLHsPar y') }
611 612 613 614
                                            -- Parenthesise both arguments and result,
                                            -- to ensure this operator application does
                                            -- does not get re-associated
                            -- See Note [Operator association]
615
    cvt (InfixE Nothing  s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
616 617
                                          ; wrapParL HsPar $ SectionR s' y' }
                                            -- See Note [Sections in HsSyn] in HsExpr
618
    cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
619
                                          ; wrapParL HsPar $ SectionL x' s' }
620

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

625
    cvt (UInfixE x s y)  = do { x' <- cvtl x
626
                              ; let x'' = case x' of
627 628 629
                                            L _ (OpApp {}) -> x'
                                            _ -> mkLHsPar x'
                              ; cvtOpApp x'' s y } --  Note [Converting UInfix]
630

631
    cvt (ParensE e)      = do { e' <- cvtl e; return $ HsPar e' }
632 633
    cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtType t
                              ; return $ ExprWithTySig e' t' }
634
    cvt (RecConE c flds) = do { c' <- cNameL c
635 636
                              ; flds' <- mapM cvtFld flds
                              ; return $ RecordCon c' noPostTcExpr (HsRecFields flds' Nothing)}
637
    cvt (RecUpdE e flds) = do { e' <- cvtl e
638 639
                              ; flds' <- mapM cvtFld flds
                              ; return $ RecordUpd e' (HsRecFields flds' Nothing) [] [] [] }
640

641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656
{- 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.
-}

657
cvtFld :: (TH.Name, TH.Exp) -> CvtM (HsRecField RdrName (LHsExpr RdrName))
658
cvtFld (v,e)
659 660
  = do  { v' <- vNameL v; e' <- cvtl e
        ; return (HsRecField { hsRecFieldId = v', hsRecFieldArg = e', hsRecPun = False}) }
661 662

cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)
663
cvtDD (FromR x)           = do { x' <- cvtl x; return $ From x' }
664 665 666 667
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' }

668 669 670 671 672 673 674 675 676 677
{- 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]
~~~~~~~~~~~~~~~~~~~~~~~~
678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727
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') }

728
-------------------------------------
729
--      Do notation and statements
730 731
-------------------------------------

732
cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr RdrName)
733
cvtHsDo do_or_lc stmts
734 735
  | null stmts = failWith (ptext (sLit "Empty stmt list in do-block"))
  | otherwise
736
  = do  { stmts' <- cvtStmts stmts
737
        ; let Just (stmts'', last') = snocView stmts'
738

739 740 741
        ; last'' <- case last' of
                    L loc (BodyStmt body _ _ _) -> return (L loc (mkLastStmt body))
                    _ -> failWith (bad_last last')
742

743
        ; return $ HsDo do_or_lc (stmts'' ++ [last'']) placeHolderType }
744
  where
745
    bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprAStmtContext do_or_lc <> colon
746
                         , nest 2 $ Outputable.ppr stmt
747
                         , ptext (sLit "(It should be an expression.)") ]
748

749
cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName (LHsExpr RdrName)]
750
cvtStmts = mapM cvtStmt
751

752 753
cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName (LHsExpr RdrName))
cvtStmt (NoBindS e)    = do { e' <- cvtl e; returnL $ mkBodyStmt e' }
754
cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
755 756
cvtStmt (TH.LetS ds)   = do { ds' <- cvtLocalDecs (ptext (sLit "a let binding")) ds
                            ; returnL $ LetStmt ds' }
757
cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noSyntaxExpr noSyntaxExpr }
758 759
                       where
                         cvt_one ds = do { ds' <- cvtStmts ds; return (ParStmtBlock ds' undefined noSyntaxExpr) }
760

761
cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName))
762
cvtMatch (TH.Match p body decs)
763 764 765 766
  = do  { p' <- cvtPat p
        ; g' <- cvtGuard body
        ; decs' <- cvtLocalDecs (ptext (sLit "a where clause")) decs
        ; returnL $ Hs.Match [p'] Nothing (GRHSs g' decs') }
767

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

772
cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName (LHsExpr RdrName))
773
cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
774 775
                              ; g' <- returnL $ mkBodyStmt ge'
                              ; returnL $ GRHS [g'] rhs' }
776
cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
777
                              ; returnL $ GRHS gs' rhs' }
778 779

cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
780
cvtOverLit (IntegerL i)
781
  = do { force i; return $ mkHsIntegral i placeHolderType}
782
cvtOverLit (RationalL r)
783
  = do { force r; return $ mkHsFractional (cvtFractionalLit r) placeHolderType}
784
cvtOverLit (StringL s)
785 786
  = do { let { s' = mkFastString s }
       ; force s'
787
       ; return $ mkHsIsString s' placeHolderType
788 789 790
       }
cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
-- An Integer is like an (overloaded) '3' in a Haskell source program
791
-- Similarly 3.5 for fractionals
792

793
{- Note [Converting strings]
794 795
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to
796
a string literal for "xy".  Of course, we might hope to get
797 798 799 800 801 802
(LitE (StringL "xy")), but not always, and allCharLs fails quickly
if it isn't a literal string
-}

allCharLs :: [TH.Exp] -> Maybe String
-- Note [Converting strings]
803 804 805
-- NB: only fire up this setup for a non-empty list, else
--     there's a danger of returning "" for [] :: [Int]!
allCharLs xs
806
  = case xs of
807 808 809 810 811 812
      LitE (CharL c) : ys -> go [c] ys
      _                   -> Nothing
  where
    go cs []                    = Just (reverse cs)
    go cs (LitE (CharL c) : ys) = go (c:cs) ys
    go _  _                     = Nothing
813

814 815
cvtLit :: Lit -> CvtM HsLit
cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim i }
Ian Lynagh's avatar
Ian Lynagh committed
816
cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim w }
817 818
cvtLit (FloatPrimL f)  = do { force f; return $ HsFloatPrim (cvtFractionalLit f) }
cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim (cvtFractionalLit f) }
819
cvtLit (CharL c)       = do { force c; return $ HsChar c }
820
cvtLit (StringL s)     = do { let { s' = mkFastString s }
821 822
                            ; force s'
                            ; return $ HsString s' }
823
cvtLit (StringPrimL s) = do { let { s' = BS.pack s }
824 825
                            ; force s'
                            ; return $ HsStringPrim s' }
826
cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
827 828 829
        -- cvtLit should not be called on IntegerL, RationalL
        -- That precondition is established right here in
        -- Convert.lhs, hence panic
830 831 832 833 834 835 836 837 838

cvtPats :: [TH.Pat] -> CvtM [Hs.LPat RdrName]
cvtPats pats = mapM cvtPat pats

cvtPat :: TH.Pat -> CvtM (Hs.LPat RdrName)
cvtPat pat = wrapL (cvtp pat)

cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName)
cvtp (TH.LitP l)
839
  | overloadedLit l    = do { l' <- cvtOverLit l
840 841 842 843
                            ; return (mkNPat l' Nothing) }
                                  -- Not right for negative patterns;
                                  -- need to think about that!
  | otherwise          = do { l' <- cvtLit l; return $ Hs.LitPat l' }
844 845
cvtp (TH.VarP s)       = do { s' <- vName s; return $ Hs.VarPat s' }
cvtp (TupP [p])        = do { p' <- cvtPat p; return $ ParPat p' } -- Note [Dropping constructors]
846 847
cvtp (TupP ps)         = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed   [] }
cvtp (UnboxedTupP ps)  = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed [] }
848 849 850
cvtp (ConP s ps)       = do { s' <- cNameL s; ps' <- cvtPats ps
                            ; return $ ConPatIn s' (PrefixCon ps') }
cvtp (InfixP p1 s p2)  = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2
851
                            ; wrapParL ParPat $
852
                              ConPatIn s' (InfixCon (mkParPat p1') (mkParPat p2')) }
853
                            -- See Note [Operator association]
854 855 856 857 858
cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix]
cvtp (ParensP p)       = do { p' <- cvtPat p; return $ ParPat p' }
cvtp (TildeP p)        = do { p' <- cvtPat p; return $ LazyPat p' }
cvtp (BangP p)         = do { p' <- cvtPat p; return $ BangPat p' }
cvtp (TH.AsP s p)      = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' }
859
cvtp TH.WildP          = return $ WildPat placeHolderType
860
cvtp (RecP c fs)       = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
861 862 863 864
                            ; return $ ConPatIn c'
                                     $ Hs.RecCon (HsRecFields fs' Nothing) }
cvtp (ListP ps)        = do { ps' <- cvtPats ps
                            ; return $ ListPat ps' placeHolderType Nothing }
865
cvtp (SigP p t)        = do { p' <- cvtPat p; t' <- cvtType t
866
                            ; return $ SigPatIn p' (mkHsWithBndrs t') }
867 868
cvtp (ViewP e p)       = do { e' <- cvtl e; p' <- cvtPat p
                            ; return $ ViewPat e' p' placeHolderType }