uhc-light-1.1.9.4: 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 VarLookupKey VarMp = VarId
type instance VarLookupVal VarMp = VarMpInfo
{-
type instance VarLookupKey (VarMp' k v) = k
type instance VarLookupVal (VarMp' k v) = v
-}
{-# LINE 91 "src/ehc/Substitutable.chs" #-}
instance (VarLookup m, VarLookupKey m ~ TyVarId, VarLookupVal m ~ VarMpInfo) => VarUpdatable Ty m where
varUpd = tyAppVarLookup
varUpdCyc = tyAppVarLookup2
type instance ExtrValVarKey Ty = TyVarId
instance VarExtractable Ty where
varFreeSet = tyFtv
{-# LINE 108 "src/ehc/Substitutable.chs" #-}
-- instance VarUpdatable Label VarMp where
instance (VarLookup m, VarLookupKey m ~ ImplsVarId, VarLookupVal m ~ VarMpInfo) => VarUpdatable Label m where
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, VarLookupKey m ~ UID, VarLookupVal m ~ VarMpInfo) => VarUpdatable LabelOffset m where
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 131 "src/ehc/Substitutable.chs" #-}
{- 20160421: in uhc-util
-- instance (VarUpdatable vv subst) => VarUpdatable [vv] subst where
instance (Ord (VarLookupKey subst), VarUpdatable vv subst) => VarUpdatable [vv] subst where
s `varUpd` l = map (varUpd s) l
s `varUpdCyc` l = (l,varmpUnions m)
where (l,m) = unzip $ map (varUpdCyc s) l
-}
{- 20160411: in uhc-util
instance (VarExtractable vv) => VarExtractable [vv] where
varFreeSet l = Set.unions $ map varFreeSet l
-}
{-# LINE 173 "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
varUpd = (|+>)
type instance ExtrValVarKey VarMp = TyVarId
instance VarExtractable VarMp where
varFreeSet (VarMp _ sl) = Set.unions $ map (varFreeSet . Map.elems) sl
{-# LINE 184 "src/ehc/Substitutable.chs" #-}
-- instance VarUpdatable vv subst => VarUpdatable (HsName,vv) subst where
instance VarUpdatable vv subst => VarUpdatable (HsName,vv) subst where
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 193 "src/ehc/Substitutable.chs" #-}
instance VarUpdatable Pred VarMp where
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, VarLookupKey m ~ ImplsVarId, VarLookupVal m ~ VarMpInfo) => VarUpdatable PredScope m where
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
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
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
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
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 261 "src/ehc/Substitutable.chs" #-}
instance VarUpdatable VarMpInfo VarMp where
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 279 "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 315 "src/ehc/Substitutable.chs" #-}
instance VarUpdatable PredSeq VarMp where
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 333 "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 363 "src/ehc/Substitutable.chs" #-}
setSubst :: VarMp -> TyVarIdS -> TyVarIdS
setSubst m s = varFreeSet $ (varUpd m) $ map mkTyVar $ Set.toList s
{-# LINE 372 "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 392 "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 409 "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 ]