type HsValBinds id = HsValBindsLR id id
data HsValBindsLR idL idR -- Value bindings (not implicit parameters)
- = ValBindsIn -- Before renaming
+ = ValBindsIn -- Before renaming RHS; idR is always RdrName
(LHsBindsLR idL idR) [LSig idR] -- Not dependency analysed
-- Recursive by default
- | ValBindsOut -- After renaming
+ | ValBindsOut -- After renaming RHS; idR can be Name or Id
[(RecFlag, LHsBinds idL)] -- Dependency analysed, later bindings
-- in the list may depend on earlier
-- ones.
[LSig Name]
deriving (Data, Typeable)
-type LHsBinds id = Bag (LHsBind id)
-type LHsBind id = Located (HsBind id)
-type HsBind id = HsBindLR id id
+type LHsBind id = LHsBindLR id id
+type LHsBinds id = LHsBindsLR id id
+type HsBind id = HsBindLR id id
-type LHsBindLR idL idR = Located (HsBindLR idL idR)
type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)
+type LHsBindLR idL idR = Located (HsBindLR idL idR)
data HsBindLR idL idR
= -- | FunBind is used for both functions @f x = e@
instance (OutputableBndr id) => Outputable (HsIPBinds id) where
ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs)
- $$ ifPprDebug (ppr ds)
+ $$ ifPprDebug (ppr ds)
instance (OutputableBndr id) => Outputable (IPBind id) where
ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs)
deriving( Data, Typeable)
evVarTerm :: EvVar -> EvTerm
- evVarTerm v | isCoVar v = EvCoercion (mkCoVarCoercion v)
+ evVarTerm v | isCoVar v = EvCoercion (mkCoVarCo v)
| otherwise = EvId v
\end{code}
help it WpHole = it
help it (WpCompose f1 f2) = help (help it f2) f1
help it (WpCast co) = add_parens $ sep [it False, nest 2 (ptext (sLit "|>")
- <+> pprParendType co)]
+ <+> pprParendCo co)]
help it (WpEvApp id) = no_parens $ sep [it True, nest 2 (ppr id)]
help it (WpTyApp ty) = no_parens $ sep [it True, ptext (sLit "@") <+> pprParendType ty]
help it (WpEvLam id) = add_parens $ sep [ ptext (sLit "\\") <> pp_bndr id, it False]
instance Outputable EvTerm where
ppr (EvId v) = ppr v
- ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendType co
- ppr (EvCoercion co) = ppr co
+ ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendCo co
+ ppr (EvCoercion co) = ptext (sLit "CO") <+> ppr co
ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n))
ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ]
\end{code}
mkHsPar, mkHsApp, mkHsConApp, mkSimpleHsAlt,
mkSimpleMatch, unguardedGRHSs, unguardedRHS,
mkMatchGroup, mkMatch, mkHsLam, mkHsIf,
- mkHsWrap, mkLHsWrap, mkHsWrapCoI, mkLHsWrapCoI,
- coiToHsWrapper, mkHsLams, mkHsDictLet,
- mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCoI,
+ mkHsWrap, mkLHsWrap, mkHsWrapCo, mkLHsWrapCo,
+ coToHsWrapper, mkHsDictLet, mkHsLams,
+ mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps,
nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
import RdrName
import Var
import Coercion
- import Type
+ import TypeRep
import DataCon
import Name
import NameSet
import BasicTypes
import SrcLoc
import FastString
-import Outputable
import Util
import Bag
mkHsWrap co_fn e | isIdHsWrapper co_fn = e
| otherwise = HsWrap co_fn e
- mkHsWrapCoI :: CoercionI -> HsExpr id -> HsExpr id
- mkHsWrapCoI (IdCo _) e = e
- mkHsWrapCoI (ACo co) e = mkHsWrap (WpCast co) e
+ mkHsWrapCo :: Coercion -> HsExpr id -> HsExpr id
+ mkHsWrapCo (Refl _) e = e
+ mkHsWrapCo co e = mkHsWrap (WpCast co) e
- mkLHsWrapCoI :: CoercionI -> LHsExpr id -> LHsExpr id
- mkLHsWrapCoI (IdCo _) e = e
- mkLHsWrapCoI (ACo co) (L loc e) = L loc (mkHsWrap (WpCast co) e)
+ mkLHsWrapCo :: Coercion -> LHsExpr id -> LHsExpr id
+ mkLHsWrapCo (Refl _) e = e
+ mkLHsWrapCo co (L loc e) = L loc (mkHsWrap (WpCast co) e)
- coiToHsWrapper :: CoercionI -> HsWrapper
- coiToHsWrapper (IdCo _) = idHsWrapper
- coiToHsWrapper (ACo co) = WpCast co
+ coToHsWrapper :: Coercion -> HsWrapper
+ coToHsWrapper (Refl _) = idHsWrapper
+ coToHsWrapper co = WpCast co
mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
| otherwise = CoPat co_fn p ty
- mkHsWrapPatCoI :: CoercionI -> Pat id -> Type -> Pat id
- mkHsWrapPatCoI (IdCo _) pat _ = pat
- mkHsWrapPatCoI (ACo co) pat ty = CoPat (WpCast co) pat ty
+ mkHsWrapPatCo :: Coercion -> Pat id -> Type -> Pat id
+ mkHsWrapPatCo (Refl _) pat _ = pat
+ mkHsWrapPatCo co pat ty = CoPat (WpCast co) pat ty
mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
hsValBindsImplicits :: HsValBindsLR Name idR -> NameSet
hsValBindsImplicits (ValBindsOut binds _)
- = unionManyNameSets [foldBag unionNameSets (hs_bind . unLoc) emptyNameSet hs_binds | (_rec, hs_binds) <- binds]
+ = foldr (unionNameSets . lhsBindsImplicits . snd) emptyNameSet binds
+hsValBindsImplicits (ValBindsIn binds _)
+ = lhsBindsImplicits binds
+
+lhsBindsImplicits :: LHsBindsLR Name idR -> NameSet
+lhsBindsImplicits = foldBag unionNameSets lhs_bind emptyNameSet
where
- hs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat
- hs_bind _ = emptyNameSet
-hsValBindsImplicits (ValBindsIn {}) = pprPanic "hsValBindsImplicits: ValBindsIn" empty
+ lhs_bind (L _ (PatBind { pat_lhs = lpat })) = lPatImplicits lpat
+ lhs_bind _ = emptyNameSet
lPatImplicits :: LPat Name -> NameSet
lPatImplicits = hs_lpat
import Outputable
import Util ( dropList )
import Data.List ( mapAccumL )
+ import Pair
import Unique
import Data.Maybe
import BasicTypes
_ -> return (TH.VarI v ty Nothing fix)
}
- reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
- reifyThing (AGlobal (AClass cls)) = reifyClass cls
+ reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
+ reifyThing (AGlobal (ACoAxiom ax)) = reifyAxiom ax
+ reifyThing (AGlobal (AClass cls)) = reifyClass cls
reifyThing (AGlobal (ADataCon dc))
= do { let name = dataConName dc
; ty <- reifyType (idType (dataConWrapId dc))
reifyThing (AThing {}) = panic "reifyThing AThing"
------------------------------
+ reifyAxiom :: CoAxiom -> TcM TH.Info
+ reifyAxiom ax@(CoAxiom { co_ax_lhs = lhs, co_ax_rhs = rhs })
+ | Just (tc, args) <- tcSplitTyConApp_maybe lhs
+ = do { args' <- mapM reifyType args
+ ; rhs' <- reifyType rhs
+ ; return (TH.TyConI $ TH.TySynInstD (reifyName tc) args' rhs') }
+ | otherwise
+ = failWith (ptext (sLit "Can't reify the axiom") <+> ppr ax
+ <+> dcolon <+> pprEqPred (Pair lhs rhs))
+
reifyTyCon :: TyCon -> TcM TH.Info
reifyTyCon tc
| isFunTyCon tc
= return (TH.PrimTyConI (reifyName tc) 2 False)
+
| isPrimTyCon tc
= return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
+
| isFamilyTyCon tc
= let flavour = reifyFamFlavour tc
tvs = tyConTyVars tc
in
return (TH.TyConI $
TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs) kind')
+
| isSynTyCon tc
= do { let (tvs, rhs) = synTyConDefn tc
; rhs' <- reifyType rhs
TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs')
}
- reifyTyCon tc
+ | otherwise
= do { cxt <- reifyCxt (tyConStupidTheta tc)
; let tvs = tyConTyVars tc
; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
reifyType :: TypeRep.Type -> TcM TH.Type
-- Monadic only because of failure
reifyType ty@(ForAllTy _ _) = reify_for_all ty
-reifyType ty@(PredTy {} `FunTy` _) = reify_for_all ty -- Types like ((?x::Int) => Char -> Char)
+reifyType ty@(PredTy {} `FunTy` _) = reify_for_all ty -- Types like ((?x::Int) => Char -> Char)
reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here
reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
projects / ghc-hetmet.git / commitdiff