uhc-light-1.1.9.2: src/UHC/Light/Compiler/Substitutable.hs
module UHC.Light.Compiler.Substitutable
( module UHC.Util.Substitutable
, ppS
, substLift
, varmpMapTyVarKey
, setSubst
, tyFixTyVars, tyMetaTyVars
, varmpinfoFtvMp
, varmpOccurErr )
where
import Data.List
import UHC.Light.Compiler.Base.Common
import UHC.Light.Compiler.VarMp
import UHC.Util.Substitutable
import UHC.Light.Compiler.Ty
import UHC.Light.Compiler.Ty.Trf.Subst
import UHC.Light.Compiler.Ty.Ftv
import qualified Data.Set as Set
import UHC.Util.Pretty
import UHC.Light.Compiler.Error
import qualified Data.Map as Map
import UHC.Light.Compiler.VarLookup
import UHC.Light.Compiler.Base.TermLike
{-# LINE 49 "src/ehc/Substitutable.chs" #-}
substLift :: (v' -> v) -> (v' -> v -> v') -> (subst -> v -> (v,r)) -> subst -> v' -> (v',r)
substLift toV updV app s v'
= (updV v' x,r)
where (x,r) = app s $ toV v'
{-# LINE 60 "src/ehc/Substitutable.chs" #-}
varmpinfoFtvMp :: VarMpInfo -> TvCatMp
varmpinfoFtvMp i
= case i of
VMITy t -> tyFtvMp t
VMIImpls i -> implsFtvMp i
_ -> emptyTvCatMp -- incomplete
{-# LINE 73 "src/ehc/Substitutable.chs" #-}
type instance SubstVarKey VarMp = VarId
type instance SubstVarVal VarMp = VarMpInfo
type instance SubstVarKey (VarMp' k v) = k
type instance SubstVarVal (VarMp' k v) = v
{-# LINE 89 "src/ehc/Substitutable.chs" #-}
instance (VarLookup m (SubstVarKey m) (SubstVarVal m), SubstVarKey m ~ TyVarId, SubstVarVal m ~ VarMpInfo) => VarUpdatable Ty m where
-- type SubstVarKey m = SubstVarKey m
-- type SubstVarVal m = SubstVarVal m
varUpd = tyAppVarLookup
varUpdCyc = tyAppVarLookup2
type instance ExtrValVarKey Ty = TyVarId
instance VarExtractable Ty where
varFreeSet = tyFtv
{-# LINE 110 "src/ehc/Substitutable.chs" #-}
-- instance VarUpdatable Label VarMp where
instance (VarLookup m (SubstVarKey m) (SubstVarVal m), SubstVarKey m ~ ImplsVarId, SubstVarVal m ~ VarMpInfo) => VarUpdatable Label m where
-- type SubstVarKey m = ImplsVarId
-- type SubstVarVal m = VarMpInfo
s `varUpd` lb = maybe lb id $ varmpLabelLookupLabelCyc lb s
type instance ExtrValVarKey Label = TyVarId
instance VarExtractable Label where
varFree (Label_Var v) = [v]
varFree _ = []
-- instance VarUpdatable LabelOffset VarMp where
instance (VarLookup m (SubstVarKey m) (SubstVarVal m), SubstVarKey m ~ UID, SubstVarVal m ~ VarMpInfo) => VarUpdatable LabelOffset m where
-- type SubstVarKey m = UID
-- type SubstVarVal m = VarMpInfo
s `varUpd` o@(LabelOffset_Var v) = maybe o id $ varmpOffsetLookup v s
s `varUpd` o = o
type instance ExtrValVarKey LabelOffset = TyVarId
instance VarExtractable LabelOffset where
varFree (LabelOffset_Var v) = [v]
varFree _ = []
{-# LINE 137 "src/ehc/Substitutable.chs" #-}
-- instance (VarUpdatable vv subst) => VarUpdatable [vv] subst where
instance (Ord (SubstVarKey subst), VarUpdatable vv subst) => VarUpdatable [vv] subst where
-- type SubstVarKey subst = SubstVarKey subst
-- type SubstVarVal subst = SubstVarVal subst
s `varUpd` l = map (varUpd s) l
s `varUpdCyc` l = (l,varmpUnions m)
where (l,m) = unzip $ map (varUpdCyc s) l
instance (VarExtractable vv) => VarExtractable [vv] where
varFreeSet l = Set.unions $ map varFreeSet l
{-# LINE 181 "src/ehc/Substitutable.chs" #-}
-- instance VarLookupCmb m (VarMp' k v) => VarUpdatable (VarMp' k v) m where
instance VarLookupCmb (VarMp' k v) (VarMp' k v) => VarUpdatable (VarMp' k v) (VarMp' k v) where
-- type SubstVarKey (VarMp' k v) = k
-- type SubstVarVal (VarMp' k v) = v
varUpd = (|+>)
type instance ExtrValVarKey VarMp = TyVarId
instance VarExtractable VarMp where
varFreeSet (VarMp _ sl) = Set.unions $ map (varFreeSet . Map.elems) sl
{-# LINE 194 "src/ehc/Substitutable.chs" #-}
-- instance VarUpdatable vv subst => VarUpdatable (HsName,vv) subst where
instance VarUpdatable vv subst => VarUpdatable (HsName,vv) subst where
-- type SubstVarKey subst = SubstVarKey subst
-- type SubstVarVal subst = SubstVarVal subst
s `varUpd` (k,v) = (k,s `varUpd` v)
instance (VarExtractable vv, ExtrValVarKey vv ~ ExtrValVarKey (HsName,vv)) => VarExtractable (HsName,vv) where
varFreeSet (_,v) = varFreeSet v
{-# LINE 205 "src/ehc/Substitutable.chs" #-}
instance VarUpdatable Pred VarMp where
-- type SubstVarKey VarMp = VarId
-- type SubstVarVal VarMp = VarMpInfo
s `varUpd` p = (\(Ty_Pred p) -> p) (s `varUpd` (Ty_Pred p))
type instance ExtrValVarKey Pred = TyVarId
instance VarExtractable Pred where
varFreeSet p = varFreeSet (Ty_Pred p)
-- instance VarUpdatable PredScope VarMp where
instance (VarLookup m (SubstVarKey m) (SubstVarVal m), SubstVarKey m ~ ImplsVarId, SubstVarVal m ~ VarMpInfo) => VarUpdatable PredScope m where
-- type SubstVarKey m = ImplsVarId
-- type SubstVarVal m = VarMpInfo
s `varUpd` sc = maybe sc id $ varmpScopeLookupScopeCyc sc s
type instance ExtrValVarKey PredScope = TyVarId
instance VarExtractable PredScope where
varFree (PredScope_Var v) = [v]
varFree _ = []
instance VarUpdatable CHRPredOccCxt VarMp where
-- type SubstVarKey VarMp = VarId
-- type SubstVarVal VarMp = VarMpInfo
s `varUpd` (CHRPredOccCxt_Scope1 sc) = CHRPredOccCxt_Scope1 (s `varUpd` sc)
type instance ExtrValVarKey CHRPredOccCxt = TyVarId
instance VarExtractable CHRPredOccCxt where
varFree (CHRPredOccCxt_Scope1 sc) = varFree sc
instance VarUpdatable PredOcc VarMp where
-- type SubstVarKey VarMp = VarId
-- type SubstVarVal VarMp = VarMpInfo
s `varUpd` (PredOcc pr id sc r) = PredOcc (s `varUpd` pr) id (s `varUpd` sc) r
type instance ExtrValVarKey PredOcc = TyVarId
instance VarExtractable PredOcc where
varFreeSet (PredOcc pr id sc _) = varFreeSet pr `Set.union` varFreeSet sc
instance VarUpdatable CHRPredOcc VarMp where
-- type SubstVarKey VarMp = VarId
-- type SubstVarVal VarMp = VarMpInfo
s `varUpd` (CHRPredOcc pr sc r) = CHRPredOcc (s `varUpd` pr) (s `varUpd` sc) r
type instance ExtrValVarKey CHRPredOcc = TyVarId
instance VarExtractable CHRPredOcc where
varFreeSet (CHRPredOcc pr sc _) = varFreeSet pr `Set.union` varFreeSet sc
instance VarUpdatable Impls VarMp where
-- type SubstVarKey VarMp = VarId
-- type SubstVarVal VarMp = VarMpInfo
s `varUpd` i = (\(Ty_Impls i) -> i) (s `varUpd` (Ty_Impls i))
type instance ExtrValVarKey Impls = TyVarId
instance VarExtractable Impls where
varFreeSet i = varFreeSet (Ty_Impls i)
{-# LINE 285 "src/ehc/Substitutable.chs" #-}
instance VarUpdatable VarMpInfo VarMp where
-- type SubstVarKey VarMp = VarId
-- type SubstVarVal VarMp = VarMpInfo
s `varUpd` vmi = case vmi of
VMITy t -> VMITy (s `varUpd` t)
VMIImpls i -> VMIImpls (s `varUpd` i)
VMIPred i -> VMIPred (s `varUpd` i)
VMIScope sc -> VMIScope (s `varUpd` sc)
VMIPredSeq x -> VMIPredSeq (s `varUpd` x)
-- VMIExts x -> VMIExts (s `varUpd` x)
vmi -> vmi
{-# LINE 305 "src/ehc/Substitutable.chs" #-}
type instance ExtrValVarKey VarMpInfo = VarId
instance VarExtractable VarMpInfo where
varFreeSet vmi = case vmi of
VMITy t -> varFreeSet t
VMIImpls i -> varFreeSet i
VMIPred i -> varFreeSet i
VMIScope sc -> varFreeSet sc
VMIPredSeq x -> varFreeSet x
-- VMIExts x -> varFreeSet x
vmi -> Set.empty
{-# LINE 341 "src/ehc/Substitutable.chs" #-}
instance VarUpdatable PredSeq VarMp where
-- type SubstVarKey VarMp = VarId
-- type SubstVarVal VarMp = VarMpInfo
s `varUpd` a@(PredSeq_Var v ) = maybe a id $ varmpPredSeqLookup v s
s `varUpd` (PredSeq_Cons h t) = PredSeq_Cons (s `varUpd` h) (s `varUpd` t)
_ `varUpd` x = x
type instance ExtrValVarKey PredSeq = TyVarId
instance VarExtractable PredSeq where
varFreeSet (PredSeq_Var v ) = Set.singleton v
varFreeSet (PredSeq_Cons h t) = varFreeSet h `Set.union` varFreeSet t
varFreeSet _ = Set.empty
{-# LINE 361 "src/ehc/Substitutable.chs" #-}
-- | Construct varmp for fixing tvars to new fresh fixed tvars + varmp for unfixing those to (again) fresh tvars, resp meta tvars
fixTyVarsVarMp :: UID -> Ty -> (VarMp,VarMp,VarMp,VarMp)
fixTyVarsVarMp uniq t
= ( mk TyVarCateg_Fixed fv rv
, mk TyVarCateg_Meta fv rv
, mk TyVarCateg_Plain rv rv2
, mk TyVarCateg_Meta rv rv2
)
where fv = varFree t
l = length fv
(rv,rv2) = splitAt l $ mkNewUIDL (2*l) uniq
mk cat fv rv = mkVarMp $ Map.fromList $ zipWith (\v r -> (v,VMITy (Ty_Var r cat))) fv rv
tyFixTyVars :: UID -> Ty -> (Ty,VarMp,VarMp,VarMp)
tyFixTyVars uniq t
= (sTo `varUpd` t, sTo, sFr, smFr)
where (sTo,_,sFr,smFr) = fixTyVarsVarMp uniq t
-- | replace tvars with tvars having TyVarCateg_Meta
tyMetaTyVars :: UID -> Ty -> Ty
tyMetaTyVars uniq t
= smTo `varUpd` t
where (_,smTo,_,_) = fixTyVarsVarMp uniq t
{-# LINE 391 "src/ehc/Substitutable.chs" #-}
setSubst :: VarMp -> TyVarIdS -> TyVarIdS
setSubst m s = varFreeSet $ (varUpd m) $ map mkTyVar $ Set.toList s
{-# LINE 400 "src/ehc/Substitutable.chs" #-}
varmpMapTyVarKey :: VarMp -> VarMp -> VarMp
varmpMapTyVarKey mMap m
= varmpUnions [ varmpTyUnit v x | (Ty_Var v _,x) <- assocLMapKey (\v -> fst $ appUnAnnCanon $ mMap `varUpd` mkTyVar v) $ varmpToAssocTyL m ]
{-# LINE 420 "src/ehc/Substitutable.chs" #-}
ppS :: VarUpdatable x m => (x -> PP_Doc) -> m -> x -> PP_Doc
ppS pp c x = (pp $ c `varUpd` x) >#< ppParens (pp x)
{-# LINE 437 "src/ehc/Substitutable.chs" #-}
varmpOccurErr :: Range -> VarMp -> VarMp -> [Err]
varmpOccurErr r m mc = [ Err_OccurCycle r v (varmpDel [v] m `varUpd` t) | (v,t) <- varmpToAssocTyL mc ]