module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
convertToHsType,
thRdrNameGuesses ) where
import HsSyn as Hs
import qualified Class
import RdrName
import qualified Name
import Module
import RdrHsSyn
import qualified OccName
import OccName
import SrcLoc
import Type
import qualified Coercion ( Role(..) )
import TysWiredIn
import TysPrim (eqPrimTyCon)
import BasicTypes as Hs
import ForeignCall
import Unique
import ErrUtils
import Bag
import Lexeme
import Util
import FastString
import Outputable
import MonadUtils ( foldrM )
import qualified Data.ByteString as BS
import Control.Monad( unless, liftM, ap )
#if __GLASGOW_HASKELL__ < 709
import Control.Applicative (Applicative(..))
#endif
import Data.Char ( chr )
import Data.Word ( Word8 )
import Data.Maybe( catMaybes, fromMaybe, isNothing )
import Language.Haskell.TH as TH hiding (sigP)
import Language.Haskell.TH.Syntax as TH
convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl RdrName]
convertToHsDecls loc ds = initCvt loc (fmap catMaybes (mapM cvt_dec ds))
where
cvt_dec d = wrapMsg "declaration" d (cvtDec d)
convertToHsExpr :: SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr RdrName)
convertToHsExpr loc e
= initCvt loc $ wrapMsg "expression" e $ cvtl e
convertToPat :: SrcSpan -> TH.Pat -> Either MsgDoc (LPat RdrName)
convertToPat loc p
= initCvt loc $ wrapMsg "pattern" p $ cvtPat p
convertToHsType :: SrcSpan -> TH.Type -> Either MsgDoc (LHsType RdrName)
convertToHsType loc t
= initCvt loc $ wrapMsg "type" t $ cvtType t
newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) }
instance Functor CvtM where
fmap = liftM
instance Applicative CvtM where
pure x = CvtM $ \loc -> Right (loc,x)
(<*>) = ap
instance Monad CvtM where
return = pure
(CvtM m) >>= k = CvtM $ \loc -> case m loc of
Left err -> Left err
Right (loc',v) -> unCvtM (k v) loc'
initCvt :: SrcSpan -> CvtM a -> Either MsgDoc a
initCvt loc (CvtM m) = fmap snd (m loc)
force :: a -> CvtM ()
force a = a `seq` return ()
failWith :: MsgDoc -> CvtM a
failWith m = CvtM (\_ -> Left m)
getL :: CvtM SrcSpan
getL = CvtM (\loc -> Right (loc,loc))
setL :: SrcSpan -> CvtM ()
setL loc = CvtM (\_ -> Right (loc, ()))
returnL :: a -> CvtM (Located a)
returnL x = CvtM (\loc -> Right (loc, L loc x))
returnJustL :: a -> CvtM (Maybe (Located a))
returnJustL = fmap Just . returnL
wrapParL :: (Located a -> a) -> a -> CvtM a
wrapParL add_par x = CvtM (\loc -> Right (loc, add_par (L loc x)))
wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b
wrapMsg what item (CvtM m)
= CvtM (\loc -> case m loc of
Left err -> Left (err $$ getPprStyle msg)
Right v -> Right v)
where
msg sty = hang (text "When splicing a TH" <+> text what <> colon)
2 (if debugStyle sty
then text (show item)
else text (pprint item))
wrapL :: CvtM a -> CvtM (Located a)
wrapL (CvtM m) = CvtM (\loc -> case m loc of
Left err -> Left err
Right (loc',v) -> Right (loc',L loc v))
cvtDecs :: [TH.Dec] -> CvtM [LHsDecl RdrName]
cvtDecs = fmap catMaybes . mapM cvtDec
cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl RdrName))
cvtDec (TH.ValD pat body ds)
| TH.VarP s <- pat
= do { s' <- vNameL s
; cl' <- cvtClause (Clause [] body ds)
; returnJustL $ Hs.ValD $ mkFunBind s' [cl'] }
| otherwise
= do { pat' <- cvtPat pat
; body' <- cvtGuard body
; ds' <- cvtLocalDecs (text "a where clause") ds
; returnJustL $ Hs.ValD $
PatBind { pat_lhs = pat', pat_rhs = GRHSs body' (noLoc ds')
, pat_rhs_ty = placeHolderType, bind_fvs = placeHolderNames
, pat_ticks = ([],[]) } }
cvtDec (TH.FunD nm cls)
| null cls
= failWith (text "Function binding for"
<+> quotes (text (TH.pprint nm))
<+> text "has no equations")
| otherwise
= do { nm' <- vNameL nm
; cls' <- mapM cvtClause cls
; returnJustL $ Hs.ValD $ mkFunBind nm' cls' }
cvtDec (TH.SigD nm typ)
= do { nm' <- vNameL nm
; ty' <- cvtType typ
; returnJustL $ Hs.SigD (TypeSig [nm'] (mkLHsSigWcType ty')) }
cvtDec (TH.InfixD fx nm)
= do { nm' <- vcNameL nm
; returnJustL (Hs.SigD (FixSig (FixitySig [nm'] (cvtFixity fx)))) }
cvtDec (PragmaD prag)
= cvtPragmaD prag
cvtDec (TySynD tc tvs rhs)
= do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
; rhs' <- cvtType rhs
; returnJustL $ TyClD $
SynDecl { tcdLName = tc'
, tcdTyVars = tvs', tcdFVs = placeHolderNames
, tcdRhs = rhs' } }
cvtDec (DataD ctxt tc tvs ksig constrs derivs)
= do { let isGadtCon (GadtC _ _ _) = True
isGadtCon (RecGadtC _ _ _) = True
isGadtCon (ForallC _ _ c) = isGadtCon c
isGadtCon _ = False
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
; cons' <- mapM cvtConstr constrs
; derivs' <- cvtDerivs derivs
; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
, dd_ctxt = ctxt'
, dd_kindSig = ksig'
, dd_cons = cons', dd_derivs = derivs' }
; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
, tcdDataDefn = defn
, tcdDataCusk = PlaceHolder
, tcdFVs = placeHolderNames }) }
cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)
= do { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs
; ksig' <- cvtKind `traverse` ksig
; con' <- cvtConstr constr
; derivs' <- cvtDerivs derivs
; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
, dd_ctxt = ctxt'
, dd_kindSig = ksig'
, dd_cons = [con']
, dd_derivs = derivs' }
; returnJustL $ TyClD (DataDecl { tcdLName = tc', tcdTyVars = tvs'
, tcdDataDefn = defn
, tcdDataCusk = PlaceHolder
, tcdFVs = placeHolderNames }) }
cvtDec (ClassD ctxt cl tvs fds decs)
= do { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs
; fds' <- mapM cvt_fundep fds
; (binds', sigs', fams', ats', adts') <- cvt_ci_decs (text "a class declaration") decs
; unless (null adts')
(failWith $ (text "Default data instance declarations"
<+> text "are not allowed:")
$$ (Outputable.ppr adts'))
; at_defs <- mapM cvt_at_def ats'
; returnJustL $ TyClD $
ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'
, tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'
, tcdMeths = binds'
, tcdATs = fams', tcdATDefs = at_defs, tcdDocs = []
, tcdFVs = placeHolderNames }
}
where
cvt_at_def :: LTyFamInstDecl RdrName -> CvtM (LTyFamDefltEqn RdrName)
cvt_at_def decl = case RdrHsSyn.mkATDefault decl of
Right def -> return def
Left (_, msg) -> failWith msg
cvtDec (InstanceD o ctxt ty decs)
= do { let doc = text "an instance declaration"
; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs
; unless (null fams') (failWith (mkBadDecMsg doc fams'))
; ctxt' <- cvtContext ctxt
; L loc ty' <- cvtType ty
; let inst_ty' = L loc $ HsQualTy { hst_ctxt = ctxt', hst_body = L loc ty' }
; returnJustL $ InstD $ ClsInstD $
ClsInstDecl { cid_poly_ty = mkLHsSigType inst_ty'
, cid_binds = binds'
, cid_sigs = Hs.mkClassOpSigs sigs'
, cid_tyfam_insts = ats', cid_datafam_insts = adts'
, 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"
cvtDec (ForeignD ford)
= do { ford' <- cvtForD ford
; returnJustL $ ForD ford' }
cvtDec (DataFamilyD tc tvs kind)
= do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs
; result <- cvtMaybeKindToFamilyResultSig kind
; returnJustL $ TyClD $ FamDecl $
FamilyDecl DataFamily tc' tvs' result Nothing }
cvtDec (DataInstD ctxt tc tys ksig constrs derivs)
= do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
; ksig' <- cvtKind `traverse` ksig
; cons' <- mapM cvtConstr constrs
; derivs' <- cvtDerivs derivs
; let defn = HsDataDefn { dd_ND = DataType, dd_cType = Nothing
, dd_ctxt = ctxt'
, dd_kindSig = ksig'
, dd_cons = cons', dd_derivs = derivs' }
; returnJustL $ InstD $ DataFamInstD
{ dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
, dfid_defn = defn
, dfid_fvs = placeHolderNames } }}
cvtDec (NewtypeInstD ctxt tc tys ksig constr derivs)
= do { (ctxt', tc', typats') <- cvt_tyinst_hdr ctxt tc tys
; ksig' <- cvtKind `traverse` ksig
; con' <- cvtConstr constr
; derivs' <- cvtDerivs derivs
; let defn = HsDataDefn { dd_ND = NewType, dd_cType = Nothing
, dd_ctxt = ctxt'
, dd_kindSig = ksig'
, dd_cons = [con'], dd_derivs = derivs' }
; returnJustL $ InstD $ DataFamInstD
{ dfid_inst = DataFamInstDecl { dfid_tycon = tc', dfid_pats = typats'
, dfid_defn = defn
, dfid_fvs = placeHolderNames } }}
cvtDec (TySynInstD tc eqn)
= do { tc' <- tconNameL tc
; eqn' <- cvtTySynEqn tc' eqn
; returnJustL $ InstD $ TyFamInstD
{ tfid_inst = TyFamInstDecl { tfid_eqn = eqn'
, tfid_fvs = placeHolderNames } } }
cvtDec (OpenTypeFamilyD head)
= do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
; returnJustL $ TyClD $ FamDecl $
FamilyDecl OpenTypeFamily tc' tyvars' result' injectivity' }
cvtDec (ClosedTypeFamilyD head eqns)
= do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head
; eqns' <- mapM (cvtTySynEqn tc') eqns
; returnJustL $ TyClD $ FamDecl $
FamilyDecl (ClosedTypeFamily (Just eqns')) tc' tyvars' result'
injectivity' }
cvtDec (TH.RoleAnnotD tc roles)
= do { tc' <- tconNameL tc
; let roles' = map (noLoc . cvtRole) roles
; returnJustL $ Hs.RoleAnnotD (RoleAnnotDecl tc' roles') }
cvtDec (TH.StandaloneDerivD cxt ty)
= do { cxt' <- cvtContext cxt
; L loc ty' <- cvtType ty
; let inst_ty' = L loc $ HsQualTy { hst_ctxt = cxt', hst_body = L loc ty' }
; returnJustL $ DerivD $
DerivDecl { deriv_type = mkLHsSigType inst_ty', deriv_overlap_mode = Nothing } }
cvtDec (TH.DefaultSigD nm typ)
= do { nm' <- vNameL nm
; ty' <- cvtType typ
; returnJustL $ Hs.SigD $ ClassOpSig True [nm'] (mkLHsSigType ty') }
cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName)
cvtTySynEqn tc (TySynEqn lhs rhs)
= do { lhs' <- mapM cvtType lhs
; rhs' <- cvtType rhs
; returnL $ TyFamEqn { tfe_tycon = tc
, tfe_pats = mkHsImplicitBndrs lhs'
, tfe_rhs = rhs' } }
cvt_ci_decs :: MsgDoc -> [TH.Dec]
-> CvtM (LHsBinds RdrName,
[LSig RdrName],
[LFamilyDecl RdrName],
[LTyFamInstDecl RdrName],
[LDataFamInstDecl RdrName])
cvt_ci_decs doc decs
= do { decs' <- cvtDecs decs
; 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'
; let (binds', prob_fams') = partitionWith is_bind prob_binds'
; let (fams', bads) = partitionWith is_fam_decl prob_fams'
; unless (null bads) (failWith (mkBadDecMsg doc bads))
; return (listToBag binds', sigs', fams', ats', adts') }
cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
-> CvtM ( LHsContext RdrName
, Located RdrName
, LHsQTyVars RdrName)
cvt_tycl_hdr cxt tc tvs
= do { cxt' <- cvtContext cxt
; tc' <- tconNameL tc
; tvs' <- cvtTvs tvs
; return (cxt', tc', tvs')
}
cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
-> CvtM ( LHsContext RdrName
, Located RdrName
, HsImplicitBndrs RdrName [LHsType RdrName])
cvt_tyinst_hdr cxt tc tys
= do { cxt' <- cvtContext cxt
; tc' <- tconNameL tc
; tys' <- mapM cvtType tys
; return (cxt', tc', mkHsImplicitBndrs tys') }
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') }
is_fam_decl :: LHsDecl RdrName -> Either (LFamilyDecl RdrName) (LHsDecl RdrName)
is_fam_decl (L loc (TyClD (FamDecl { tcdFam = d }))) = Left (L loc d)
is_fam_decl decl = Right decl
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
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)
is_bind decl = Right decl
mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc
mkBadDecMsg doc bads
= sep [ text "Illegal declaration(s) in" <+> doc <> colon
, nest 2 (vcat (map Outputable.ppr bads)) ]
cvtConstr :: TH.Con -> CvtM (LConDecl RdrName)
cvtConstr (NormalC c strtys)
= do { c' <- cNameL c
; cxt' <- returnL []
; tys' <- mapM cvt_arg strtys
; returnL $ mkConDeclH98 c' Nothing cxt' (PrefixCon tys') }
cvtConstr (RecC c varstrtys)
= do { c' <- cNameL c
; cxt' <- returnL []
; args' <- mapM cvt_id_arg varstrtys
; returnL $ mkConDeclH98 c' Nothing cxt'
(RecCon (noLoc args')) }
cvtConstr (InfixC st1 c st2)
= do { c' <- cNameL c
; cxt' <- returnL []
; st1' <- cvt_arg st1
; st2' <- cvt_arg st2
; returnL $ mkConDeclH98 c' Nothing cxt' (InfixCon st1' st2') }
cvtConstr (ForallC tvs ctxt con)
= do { tvs' <- cvtTvs tvs
; L loc ctxt' <- cvtContext ctxt
; 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'))) } }
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'
; returnL $ mkGadtDecl c' (mkLHsSigType c_ty)}
cvtConstr (RecGadtC c varstrtys ty)
= do { c' <- mapM cNameL c
; ty' <- cvtType ty
; rec_flds <- mapM cvt_id_arg varstrtys
; let rec_ty = noLoc (HsFunTy (noLoc $ HsRecTy rec_flds) ty')
; returnL $ mkGadtDecl c' (mkLHsSigType rec_ty) }
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)
= do { ty' <- cvtType ty
; let su' = cvtSrcUnpackedness su
; let ss' = cvtSrcStrictness ss
; returnL $ HsBangTy (HsSrcBang Nothing su' ss') ty' }
cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField RdrName)
cvt_id_arg (i, str, ty)
= do { L li i' <- vNameL i
; ty' <- cvt_arg (str,ty)
; return $ noLoc (ConDeclField
{ cd_fld_names
= [L li $ FieldOcc (L li i') PlaceHolder]
, cd_fld_type = ty'
, cd_fld_doc = Nothing}) }
cvtDerivs :: TH.Cxt -> CvtM (HsDeriving RdrName)
cvtDerivs [] = return Nothing
cvtDerivs cs = fmap (Just . mkSigTypes) (cvtContext cs)
where
mkSigTypes :: Located (HsContext RdrName) -> Located [LHsSigType RdrName]
mkSigTypes = fmap (map mkLHsSigType)
cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep (Located RdrName)))
cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs
; ys' <- mapM tNameL ys
; returnL (xs', ys') }
cvtForD :: Foreign -> CvtM (ForeignDecl RdrName)
cvtForD (ImportF callconv safety from nm ty)
| 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))
| Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety')
(mkFastString (TH.nameBase nm))
from (noLoc from)
= mk_imp impspec
| otherwise
= failWith $ text (show from) <+> text "is not a valid ccall impent"
where
mk_imp impspec
= do { nm' <- vNameL nm
; ty' <- cvtType ty
; return (ForeignImport { fd_name = nm'
, fd_sig_ty = mkLHsSigType ty'
, fd_co = noForeignImportCoercionYet
, fd_fi = impspec })
}
safety' = case safety of
Unsafe -> PlayRisky
Safe -> PlaySafe
Interruptible -> PlayInterruptible
cvtForD (ExportF callconv as nm ty)
= do { nm' <- vNameL nm
; ty' <- cvtType ty
; let e = CExport (noLoc (CExportStatic as
(mkFastString as)
(cvt_conv callconv)))
(noLoc as)
; return $ ForeignExport { fd_name = nm'
, fd_sig_ty = mkLHsSigType ty'
, fd_co = noForeignExportCoercionYet
, fd_fe = e } }
cvt_conv :: TH.Callconv -> CCallConv
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
cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl RdrName))
cvtPragmaD (InlineP nm inline rm phases)
= do { nm' <- vNameL nm
; let dflt = dfltActivation inline
; let ip = InlinePragma { inl_src = "{-# INLINE"
, inl_inline = cvtInline inline
, inl_rule = cvtRuleMatch rm
, inl_act = cvtPhases phases dflt
, inl_sat = Nothing }
; returnJustL $ Hs.SigD $ InlineSig nm' ip }
cvtPragmaD (SpecialiseP nm ty inline phases)
= do { nm' <- vNameL nm
; ty' <- cvtType ty
; let (inline', dflt) = case inline of
Just inline1 -> (cvtInline inline1, dfltActivation inline1)
Nothing -> (EmptyInlineSpec, AlwaysActive)
; let ip = InlinePragma { inl_src = "{-# INLINE"
, inl_inline = inline'
, inl_rule = Hs.FunLike
, inl_act = cvtPhases phases dflt
, inl_sat = Nothing }
; returnJustL $ Hs.SigD $ SpecSig nm' [mkLHsSigType ty'] ip }
cvtPragmaD (SpecialiseInstP ty)
= do { ty' <- cvtType ty
; returnJustL $ Hs.SigD $
SpecInstSig "{-# SPECIALISE" (mkLHsSigType 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
; returnJustL $ Hs.RuleD
$ HsRules "{-# RULES" [noLoc $ HsRule (noLoc (nm,nm')) act bndrs'
lhs' placeHolderNames
rhs' placeHolderNames]
}
cvtPragmaD (AnnP target exp)
= do { exp' <- cvtl exp
; target' <- case target of
ModuleAnnotation -> return ModuleAnnProvenance
TypeAnnotation n -> do
n' <- tconName n
return (TypeAnnProvenance (noLoc n'))
ValueAnnotation n -> do
n' <- vcName n
return (ValueAnnProvenance (noLoc n'))
; returnJustL $ Hs.AnnD $ HsAnnotation "{-# ANN" target' exp'
}
cvtPragmaD (LineP line file)
= do { setL (srcLocSpan (mkSrcLoc (fsLit file) line 1))
; return Nothing
}
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 (show i) i
cvtPhases (BeforePhase i) _ = ActiveBefore (show i) i
cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr RdrName)
cvtRuleBndr (RuleVar n)
= do { n' <- vNameL n
; return $ noLoc $ Hs.RuleBndr n' }
cvtRuleBndr (TypedRuleVar n ty)
= do { n' <- vNameL n
; ty' <- cvtType ty
; return $ noLoc $ Hs.RuleBndrSig n' $ mkLHsSigWcType ty' }
cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds RdrName)
cvtLocalDecs doc ds
| null ds
= return EmptyLocalBinds
| otherwise
= do { ds' <- cvtDecs ds
; let (binds, prob_sigs) = partitionWith is_bind ds'
; let (sigs, bads) = partitionWith is_sig prob_sigs
; unless (null bads) (failWith (mkBadDecMsg doc bads))
; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) }
cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName))
cvtClause (Clause ps body wheres)
= do { ps' <- cvtPats ps
; g' <- cvtGuard body
; ds' <- cvtLocalDecs (text "a where clause") wheres
; returnL $ Hs.Match NonFunBindMatch ps' Nothing
(GRHSs g' (noLoc ds')) }
cvtl :: TH.Exp -> CvtM (LHsExpr RdrName)
cvtl e = wrapL (cvt e)
where
cvt (VarE s) = do { s' <- vName s; return $ HsVar (noLoc s') }
cvt (ConE s) = do { s' <- cName s; return $ HsVar (noLoc s') }
cvt (LitE l)
| overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }
| otherwise = do { l' <- cvtLit l; return $ HsLit l' }
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' }
cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e
; return $ HsLam (mkMatchGroup FromSource [mkSimpleMatch ps' e']) }
cvt (LamCaseE ms) = do { ms' <- mapM cvtMatch ms
; return $ HsLamCase placeHolderType
(mkMatchGroup FromSource ms')
}
cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar e' }
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 }
cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
; return $ HsIf (Just noSyntaxExpr) x' y' z' }
cvt (MultiIfE alts)
| null alts = failWith (text "Multi-way if-expression with no alternatives")
| otherwise = do { alts' <- mapM cvtpair alts
; return $ HsMultiIf placeHolderType alts' }
cvt (LetE ds e) = do { ds' <- cvtLocalDecs (text "a let expression") ds
; e' <- cvtl e; return $ HsLet (noLoc ds') e' }
cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
; return $ HsCase e' (mkMatchGroup FromSource ms') }
cvt (DoE ss) = cvtHsDo DoExpr ss
cvt (CompE ss) = cvtHsDo ListComp ss
cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr Nothing dd' }
cvt (ListE xs)
| Just s <- allCharLs xs = do { l' <- cvtLit (StringL s); return (HsLit l') }
| otherwise = do { xs' <- mapM cvtl xs
; return $ ExplicitList placeHolderType Nothing xs'
}
cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
; wrapParL HsPar $
OpApp (mkLHsPar x') s' undefined (mkLHsPar y') }
cvt (InfixE Nothing s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
; wrapParL HsPar $ SectionR s' y' }
cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
; wrapParL HsPar $ SectionL x' s' }
cvt (InfixE Nothing s Nothing ) = do { s' <- cvtl s; return $ HsPar s' }
cvt (UInfixE x s y) = do { x' <- cvtl x
; let x'' = case x' of
L _ (OpApp {}) -> x'
_ -> mkLHsPar x'
; cvtOpApp x'' s y }
cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar e' }
cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t
; return $ ExprWithTySig e' (mkLHsSigWcType t') }
cvt (RecConE c flds) = do { c' <- cNameL c
; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds
; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) }
cvt (RecUpdE e flds) = do { e' <- cvtl e
; flds'
<- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc))
flds
; return $ mkRdrRecordUpd e' flds' }
cvt (StaticE e) = fmap HsStatic $ cvtl e
cvt (UnboundVarE s) = do { s' <- vName s; return $ HsVar (noLoc s') }
cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp) -> CvtM (LHsRecField' t (LHsExpr RdrName))
cvtFld f (v,e)
= do { v' <- vNameL v; e' <- cvtl e
; return (noLoc $ HsRecField { hsRecFieldLbl = fmap f v'
, hsRecFieldArg = e'
, hsRecPun = False}) }
cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)
cvtDD (FromR x) = do { x' <- cvtl x; return $ From x' }
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' }
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') }
cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr RdrName)
cvtHsDo do_or_lc stmts
| null stmts = failWith (text "Empty stmt list in do-block")
| otherwise
= do { stmts' <- cvtStmts stmts
; let Just (stmts'', last') = snocView stmts'
; last'' <- case last' of
L loc (BodyStmt body _ _ _) -> return (L loc (mkLastStmt body))
_ -> failWith (bad_last last')
; return $ HsDo do_or_lc (noLoc (stmts'' ++ [last''])) placeHolderType }
where
bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAStmtContext do_or_lc <> colon
, nest 2 $ Outputable.ppr stmt
, text "(It should be an expression.)" ]
cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt RdrName (LHsExpr RdrName)]
cvtStmts = mapM cvtStmt
cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName (LHsExpr RdrName))
cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkBodyStmt e' }
cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (text "a let binding") ds
; returnL $ LetStmt (noLoc ds') }
cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noExpr noSyntaxExpr placeHolderType }
where
cvt_one ds = do { ds' <- cvtStmts ds; return (ParStmtBlock ds' undefined noSyntaxExpr) }
cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName))
cvtMatch (TH.Match p body decs)
= do { p' <- cvtPat p
; g' <- cvtGuard body
; decs' <- cvtLocalDecs (text "a where clause") decs
; returnL $ Hs.Match NonFunBindMatch [p'] Nothing
(GRHSs g' (noLoc decs')) }
cvtGuard :: TH.Body -> CvtM [LGRHS RdrName (LHsExpr RdrName)]
cvtGuard (GuardedB pairs) = mapM cvtpair pairs
cvtGuard (NormalB e) = do { e' <- cvtl e; g' <- returnL $ GRHS [] e'; return [g'] }
cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS RdrName (LHsExpr RdrName))
cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs
; g' <- returnL $ mkBodyStmt ge'
; returnL $ GRHS [g'] rhs' }
cvtpair (PatG gs,rhs) = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
; returnL $ GRHS gs' rhs' }
cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
cvtOverLit (IntegerL i)
= do { force i; return $ mkHsIntegral (show i) i placeHolderType}
cvtOverLit (RationalL r)
= do { force r; return $ mkHsFractional (cvtFractionalLit r) placeHolderType}
cvtOverLit (StringL s)
= do { let { s' = mkFastString s }
; force s'
; return $ mkHsIsString s s' placeHolderType
}
cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"
allCharLs :: [TH.Exp] -> Maybe String
allCharLs xs
= case xs of
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
cvtLit :: Lit -> CvtM HsLit
cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim (show i) i }
cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim (show w) w }
cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim (cvtFractionalLit f) }
cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim (cvtFractionalLit f) }
cvtLit (CharL c) = do { force c; return $ HsChar (show c) c }
cvtLit (CharPrimL c) = do { force c; return $ HsCharPrim (show c) c }
cvtLit (StringL s) = do { let { s' = mkFastString s }
; force s'
; return $ HsString s s' }
cvtLit (StringPrimL s) = do { let { s' = BS.pack s }
; force s'
; return $ HsStringPrim (w8ToString s) s' }
cvtLit _ = panic "Convert.cvtLit: Unexpected literal"
w8ToString :: [Word8] -> String
w8ToString ws = map (\w -> chr (fromIntegral w)) ws
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)
| overloadedLit l = do { l' <- cvtOverLit l
; return (mkNPat (noLoc l') Nothing) }
| otherwise = do { l' <- cvtLit l; return $ Hs.LitPat l' }
cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat (noLoc s') }
cvtp (TupP [p]) = do { p' <- cvtPat p; return $ ParPat p' }
cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed [] }
cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed [] }
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
; wrapParL ParPat $
ConPatIn s' (InfixCon (mkParPat p1') (mkParPat p2')) }
cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 }
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' }
cvtp TH.WildP = return $ WildPat placeHolderType
cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
; return $ ConPatIn c'
$ Hs.RecCon (HsRecFields fs' Nothing) }
cvtp (ListP ps) = do { ps' <- cvtPats ps
; return $ ListPat ps' placeHolderType Nothing }
cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t
; return $ SigPatIn p' (mkLHsSigWcType t') }
cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p
; return $ ViewPat e' p' placeHolderType }
cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField RdrName (LPat RdrName))
cvtPatFld (s,p)
= do { L ls s' <- vNameL s; p' <- cvtPat p
; return (noLoc $ HsRecField { hsRecFieldLbl
= L ls $ mkFieldOcc (L ls s')
, hsRecFieldArg = p'
, hsRecPun = False}) }
cvtOpAppP :: Hs.LPat RdrName -> TH.Name -> TH.Pat -> CvtM (Hs.Pat RdrName)
cvtOpAppP x op1 (UInfixP y op2 z)
= do { l <- wrapL $ cvtOpAppP x op1 y
; cvtOpAppP l op2 z }
cvtOpAppP x op y
= do { op' <- cNameL op
; y' <- cvtPat y
; return (ConPatIn op' (InfixCon x y')) }
cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsQTyVars RdrName)
cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') }
cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
cvt_tv (TH.PlainTV nm)
= do { nm' <- tNameL nm
; returnL $ UserTyVar nm' }
cvt_tv (TH.KindedTV nm ki)
= do { nm' <- tNameL nm
; ki' <- cvtKind ki
; returnL $ KindedTyVar nm' ki' }
cvtRole :: TH.Role -> Maybe Coercion.Role
cvtRole TH.NominalR = Just Coercion.Nominal
cvtRole TH.RepresentationalR = Just Coercion.Representational
cvtRole TH.PhantomR = Just Coercion.Phantom
cvtRole TH.InferR = Nothing
cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
cvtPred :: TH.Pred -> CvtM (LHsType RdrName)
cvtPred = cvtType
cvtType :: TH.Type -> CvtM (LHsType RdrName)
cvtType = cvtTypeKind "type"
cvtTypeKind :: String -> TH.Type -> CvtM (LHsType RdrName)
cvtTypeKind ty_str ty
= do { (head_ty, tys') <- split_ty_app ty
; case head_ty of
TupleT n
| length tys' == n
-> if n==1 then return (head tys')
else returnL (HsTupleTy HsBoxedOrConstraintTuple tys')
| n == 1
-> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor")))
| otherwise
-> mk_apps (HsTyVar (noLoc (getRdrName (tupleTyCon Boxed n)))) tys'
UnboxedTupleT n
| length tys' == n
-> if n==1 then return (head tys')
else returnL (HsTupleTy HsUnboxedTuple tys')
| otherwise
-> mk_apps (HsTyVar (noLoc (getRdrName (tupleTyCon Unboxed n))))
tys'
ArrowT
| [x',y'] <- tys' -> returnL (HsFunTy x' y')
| otherwise -> mk_apps (HsTyVar (noLoc (getRdrName funTyCon))) tys'
ListT
| [x'] <- tys' -> returnL (HsListTy x')
| otherwise
-> mk_apps (HsTyVar (noLoc (getRdrName listTyCon))) tys'
VarT nm -> do { nm' <- tNameL nm
; mk_apps (HsTyVar nm') tys' }
ConT nm -> do { nm' <- tconName nm
; mk_apps (HsTyVar (noLoc nm')) tys' }
ForallT tvs cxt ty
| null tys'
-> do { tvs' <- cvtTvs tvs
; cxt' <- cvtContext cxt
; ty' <- cvtType ty
; loc <- getL
; let hs_ty | null tvs = rho_ty
| otherwise = L loc (HsForAllTy { hst_bndrs = hsQTvExplicit tvs'
, hst_body = rho_ty })
rho_ty | null cxt = ty'
| otherwise = L loc (HsQualTy { hst_ctxt = cxt'
, hst_body = ty' })
; return hs_ty }
SigT ty ki
-> do { ty' <- cvtType ty
; ki' <- cvtKind ki
; mk_apps (HsKindSig ty' ki') tys'
}
LitT lit
-> returnL (HsTyLit (cvtTyLit lit))
WildCardT
-> mk_apps mkAnonWildCardTy tys'
InfixT t1 s t2
-> do { s' <- tconName s
; t1' <- cvtType t1
; t2' <- cvtType t2
; mk_apps (HsTyVar (noLoc s')) [t1', t2']
}
UInfixT t1 s t2
-> do { t1' <- cvtType t1
; t2' <- cvtType t2
; s' <- tconName s
; return $ cvtOpAppT t1' s' t2'
}
ParensT t
-> do { t' <- cvtType t
; returnL $ HsParTy t'
}
PromotedT nm -> do { nm' <- cName nm
; mk_apps (HsTyVar (noLoc nm')) tys' }
PromotedTupleT n
| n == 1
-> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str)))
| m == n
-> do { let kis = replicate m placeHolderKind
; returnL (HsExplicitTupleTy kis tys')
}
where
m = length tys'
PromotedNilT
-> returnL (HsExplicitListTy placeHolderKind [])
PromotedConsT
| [ty1, L _ (HsExplicitListTy _ tys2)] <- tys'
-> returnL (HsExplicitListTy placeHolderKind (ty1:tys2))
| otherwise
-> mk_apps (HsTyVar (noLoc (getRdrName consDataCon))) tys'
StarT
-> returnL (HsTyVar (noLoc (getRdrName liftedTypeKindTyCon)))
ConstraintT
-> returnL (HsTyVar (noLoc (getRdrName constraintKindTyCon)))
EqualityT
| [x',y'] <- tys' -> returnL (HsEqTy x' y')
| otherwise
-> mk_apps (HsTyVar (noLoc (getRdrName eqPrimTyCon))) tys'
_ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))
}
mk_apps :: HsType RdrName -> [LHsType RdrName] -> CvtM (LHsType RdrName)
mk_apps head_ty [] = returnL head_ty
mk_apps head_ty (ty:tys) = do { head_ty' <- returnL head_ty
; mk_apps (HsAppTy head_ty' ty) tys }
mk_arr_apps :: [LHsType RdrName] -> HsType RdrName -> CvtM (LHsType RdrName)
mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL
where go :: LHsType RdrName -> HsType RdrName -> CvtM (HsType RdrName)
go arg ret_ty = do { ret_ty_l <- returnL ret_ty
; return (HsFunTy arg ret_ty_l) }
split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType RdrName])
split_ty_app ty = go ty []
where
go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') }
go f as = return (f,as)
cvtTyLit :: TH.TyLit -> HsTyLit
cvtTyLit (TH.NumTyLit i) = HsNumTy (show i) i
cvtTyLit (TH.StrTyLit s) = HsStrTy s (fsLit s)
cvtOpAppT :: LHsType RdrName -> RdrName -> LHsType RdrName -> LHsType RdrName
cvtOpAppT t1@(L loc1 _) op t2@(L loc2 _)
= L (combineSrcSpans loc1 loc2) $
HsAppsTy (t1' ++ [noLoc $ HsAppInfix (noLoc op)] ++ t2')
where
t1' | L _ (HsAppsTy t1s) <- t1
= t1s
| otherwise
= [noLoc $ HsAppPrefix t1]
t2' | L _ (HsAppsTy t2s) <- t2
= t2s
| otherwise
= [noLoc $ HsAppPrefix t2]
cvtKind :: TH.Kind -> CvtM (LHsKind RdrName)
cvtKind = cvtTypeKind "kind"
cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind
-> CvtM (LFamilyResultSig RdrName)
cvtMaybeKindToFamilyResultSig Nothing = returnL Hs.NoSig
cvtMaybeKindToFamilyResultSig (Just ki) = do { ki' <- cvtKind ki
; returnL (Hs.KindSig ki') }
cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig RdrName)
cvtFamilyResultSig TH.NoSig = returnL Hs.NoSig
cvtFamilyResultSig (TH.KindSig ki) = do { ki' <- cvtKind ki
; returnL (Hs.KindSig ki') }
cvtFamilyResultSig (TH.TyVarSig bndr) = do { tv <- cvt_tv bndr
; returnL (Hs.TyVarSig tv) }
cvtInjectivityAnnotation :: TH.InjectivityAnn
-> CvtM (Hs.LInjectivityAnn RdrName)
cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS)
= do { annLHS' <- tNameL annLHS
; annRHS' <- mapM tNameL annRHS
; returnL (Hs.InjectivityAnn annLHS' annRHS') }
cvtFixity :: TH.Fixity -> Hs.Fixity
cvtFixity (TH.Fixity prec dir) = Hs.Fixity (show prec) prec (cvt_dir dir)
where
cvt_dir TH.InfixL = Hs.InfixL
cvt_dir TH.InfixR = Hs.InfixR
cvt_dir TH.InfixN = Hs.InfixN
overloadedLit :: Lit -> Bool
overloadedLit (IntegerL _) = True
overloadedLit (RationalL _) = True
overloadedLit _ = False
cvtFractionalLit :: Rational -> FractionalLit
cvtFractionalLit r = FL { fl_text = show (fromRational r :: Double), fl_value = r }
vNameL, cNameL, vcNameL, tNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
vName, cName, vcName, tName, tconName :: TH.Name -> CvtM RdrName
vNameL n = wrapL (vName n)
vName n = cvtName OccName.varName n
cNameL n = wrapL (cName n)
cName n = cvtName OccName.dataName n
vcNameL n = wrapL (vcName n)
vcName n = if isVarName n then vName n else cName n
tNameL n = wrapL (tName n)
tName n = cvtName OccName.tvName n
tconNameL n = wrapL (tconName n)
tconName n = cvtName OccName.tcClsName n
cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
cvtName ctxt_ns (TH.Name occ flavour)
| not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
| otherwise
= do { loc <- getL
; let rdr_name = thRdrName loc ctxt_ns occ_str flavour
; force rdr_name
; return rdr_name }
where
occ_str = TH.occString occ
okOcc :: OccName.NameSpace -> String -> Bool
okOcc ns str
| OccName.isVarNameSpace ns = okVarOcc str
| OccName.isDataConNameSpace ns = okConOcc str
| otherwise = okTcOcc str
isVarName :: TH.Name -> Bool
isVarName (TH.Name occ _)
= case TH.occString occ of
"" -> False
(c:_) -> startsVarId c || startsVarSym c
badOcc :: OccName.NameSpace -> String -> SDoc
badOcc ctxt_ns occ
= text "Illegal" <+> pprNameSpace ctxt_ns
<+> text "name:" <+> quotes (text occ)
thRdrName :: SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
thRdrName loc ctxt_ns th_occ th_name
= case th_name of
TH.NameG th_ns pkg mod -> thOrigRdrName th_occ th_ns pkg mod
TH.NameQ mod -> (mkRdrQual $! mk_mod mod) $! occ
TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq uniq) $! occ) loc)
TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq uniq) $! occ) loc)
TH.NameS | Just name <- isBuiltInOcc_maybe occ -> nameRdrName $! name
| otherwise -> mkRdrUnqual $! occ
where
occ :: OccName.OccName
occ = mk_occ ctxt_ns th_occ
thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName
thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)
thRdrNameGuesses :: TH.Name -> [RdrName]
thRdrNameGuesses (TH.Name occ flavour)
| TH.NameG th_ns pkg mod <- flavour = [ thOrigRdrName occ_str th_ns pkg mod]
| otherwise = [ thRdrName noSrcSpan gns occ_str flavour
| gns <- guessed_nss]
where
guessed_nss | isLexCon (mkFastString occ_str) = [OccName.tcName, OccName.dataName]
| otherwise = [OccName.varName, OccName.tvName]
occ_str = TH.occString occ
mk_occ :: OccName.NameSpace -> String -> OccName.OccName
mk_occ ns occ = OccName.mkOccName ns occ
mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
mk_ghc_ns TH.DataName = OccName.dataName
mk_ghc_ns TH.TcClsName = OccName.tcClsName
mk_ghc_ns TH.VarName = OccName.varName
mk_mod :: TH.ModName -> ModuleName
mk_mod mod = mkModuleName (TH.modString mod)
mk_pkg :: TH.PkgName -> UnitId
mk_pkg pkg = stringToUnitId (TH.pkgString pkg)
mk_uniq :: Int -> Unique
mk_uniq u = mkUniqueGrimily u