chr-data-0.1.0.0: src/CHR/Data/VarMp.hs
{- |
A VarMp maps from variables (tvars, ...) to whatever else has to be
mapped to (Ty, ...).
Starting with variant 6 (which introduces kinds) it allows multiple meta
level mapping, in that the VarMp holds mappings for multiple meta
levels. This allows one map to both map to base level info and to higher
levels. In particular this is used by fitsIn which also instantiates
types, and types may quantify over type variables with other kinds than
kind *, which must be propagated. A separate map could have been used,
but this holds the info together and is extendible to more levels.
A multiple level VarMp knows its own absolute metalevel, which is the default to use for lookup.
-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DeriveDataTypeable #-}
-- {-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE DeriveGeneric #-}
module CHR.Data.VarMp
( VarMp'(..)
-- , VarMp
-- , ppVarMpV
-- , vmiMbTy
-- , tyAsVarMp', tyAsVarMp
-- , varmpFilterTy
, varmpFilter
, varmpDel, (|\>)
, varmpAlter
, varmpUnion, varmpUnions
--, varmpTyLookupCyc
--, varmpTyLookupCyc2
, module CHR.Data.VarLookup
-- , VarMpInfo (..)
, mkVarMp
, emptyVarMp, varmpIsEmpty
, varmpShiftMetaLev, varmpIncMetaLev, varmpDecMetaLev
, varmpSelectMetaLev
, varmpKeys, varmpKeysSet
, varmpMetaLevSingleton, varmpSingleton
, assocMetaLevLToVarMp, assocLToVarMp
-- , assocMetaLevTyLToVarMp, assocTyLToVarMp, varmpToAssocTyL
, varmpToAssocL
, varmpPlus
, varmpUnionWith
-- , instToL1VarMp
-- , varmpMetaLevTyUnit, varmpTyUnit
-- , tyRestrictKiVarMp
, varmpLookup
-- , varmpTyLookup
-- , ppVarMp
, varmpAsMap
, varmpMapMaybe, varmpMap
, varmpInsertWith
{-
, VarMpStk'
, emptyVarMpStk, varmpstkUnit
, varmpstkPushEmpty, varmpstkPop
, varmpstkToAssocL, varmpstkKeysSet
, varmpstkUnions
-}
, varmpSize
-- , vmiMbImpls, vmiMbScope, vmiMbPred, vmiMbAssNm
-- , varmpTailAddOcc
-- , varmpMapThr
-- , varmpMapThrTy
-- , varmpImplsUnit, assocImplsLToVarMp, varmpScopeUnit, varmpPredUnit, varmpAssNmUnit
-- , varmpImplsLookup, varmpScopeLookup, varmpPredLookup
-- , varmpImplsLookupImplsCyc, varmpImplsLookupCyc, varmpScopeLookupScopeCyc, varmpAssNmLookupAssNmCyc
-- , varmpPredLookup2, varmpScopeLookup2, varmpAssNmLookup2, varmpImplsLookupCyc2
-- , vmiMbLabel, vmiMbOffset
-- , varmpLabelUnit, varmpOffsetUnit
-- , varmpLabelLookup, varmpOffsetLookup
-- , varmpLabelLookupCyc, varmpLabelLookupLabelCyc
-- , vmiMbPredSeq
-- , varmpPredSeqUnit
-- , varmpPredSeqLookup
, varmpToMap
-- , varmpinfoMkVar
-- , ppVarMpInfoCfgTy, ppVarMpInfoDt
)
where
import Data.List
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Maybe
import CHR.Pretty
import CHR.Data.AssocL
import CHR.Data.VarLookup
import CHR.Data.Lookup.Types (Lookup)
import qualified CHR.Data.Lookup as Lk
import CHR.Utils
import Control.Monad
import Data.Typeable (Typeable)
import GHC.Generics
-- import UHC.Util.Serialize
data VarMp' k v
= VarMp
{ varmpMetaLev :: !MetaLev -- ^ the base meta level
, varmpMpL :: [Map.Map k v] -- ^ for each level a map, starting at the base meta level
}
deriving (Eq, Ord, Typeable, Generic)
type instance VarLookupKey (VarMp' k v) = k
type instance VarLookupVal (VarMp' k v) = v
-- get the base meta level map, ignore the others
varmpToMap :: VarMp' k v -> Map.Map k v
varmpToMap (VarMp _ (m:_)) = m
{-# INLINE varmpToMap #-}
mkVarMp :: Map.Map k v -> VarMp' k v
mkVarMp m = VarMp 0 [m]
{-# INLINE mkVarMp #-}
emptyVarMp :: VarMp' k v
emptyVarMp = mkVarMp Map.empty
{-# INLINE emptyVarMp #-}
varmpIsEmpty :: VarMp' k v -> Bool
varmpIsEmpty (VarMp {varmpMpL=l}) = all Map.null l
varmpFilter :: Ord k => (k -> v -> Bool) -> VarMp' k v -> VarMp' k v
varmpFilter f (VarMp l c) = VarMp l (map (Map.filterWithKey f) c)
varmpPartition :: Ord k => (k -> v -> Bool) -> VarMp' k v -> (VarMp' k v,VarMp' k v)
varmpPartition f (VarMp l m)
= (VarMp l p1, VarMp l p2)
where (p1,p2) = unzip $ map (Map.partitionWithKey f) m
(|\>) :: Ord k => VarMp' k v -> [k] -> VarMp' k v
(|\>) = flip varmpDel
-- | Delete
varmpDel :: Ord k => [k] -> VarMp' k v -> VarMp' k v
varmpDel tvL c = varmpFilter (const.not.(`elem` tvL)) c
-- | Alter irrespective of level
varmpAlter :: Ord k => (Maybe v -> Maybe v) -> k -> VarMp' k v -> VarMp' k v
varmpAlter f k (VarMp l c) = VarMp l (map (Map.alter f k) c)
-- shift up the level,
-- or down when negative, throwing away the lower levels
varmpShiftMetaLev :: MetaLev -> VarMp' k v -> VarMp' k v
varmpShiftMetaLev inc (VarMp mlev fm)
| inc < 0 = let mlev' = mlev+inc in VarMp (mlev' `max` 0) (drop (- (mlev' `min` 0)) fm)
| otherwise = VarMp (mlev+inc) fm
varmpIncMetaLev :: VarMp' k v -> VarMp' k v
varmpIncMetaLev = varmpShiftMetaLev 1
varmpDecMetaLev :: VarMp' k v -> VarMp' k v
varmpDecMetaLev = varmpShiftMetaLev (-1)
varmpSelectMetaLev :: [MetaLev] -> VarMp' k v -> VarMp' k v
varmpSelectMetaLev mlevs (VarMp mlev ms)
= (VarMp mlev [ if l `elem` mlevs then m else Map.empty | (l,m) <- zip [mlev..] ms ])
-- | Extract first level map, together with a construction function putting a new map into the place of the previous one
varmpAsMap :: VarMp' k v -> (Map.Map k v, Map.Map k v -> VarMp' k v)
varmpAsMap (VarMp mlev (m:ms)) = (m, \m' -> VarMp mlev (m':ms))
-- VarMp: properties
varmpSize :: VarMp' k v -> Int
varmpSize (VarMp _ m) = sum $ map Map.size m
varmpKeys :: Ord k => VarMp' k v -> [k]
varmpKeys (VarMp _ fm) = Map.keys $ Map.unions fm
varmpKeysSet :: Ord k => VarMp' k v -> Set.Set k
varmpKeysSet (VarMp _ fm) = Set.unions $ map Map.keysSet fm
{-# DEPRECATED varmpMetaLevSingleton "Use varlookupSingletonWithMetaLev" #-}
-- | VarMp singleton
varmpMetaLevSingleton :: Ord k => MetaLev -> k -> v -> VarMp' k v
varmpMetaLevSingleton = varlookupSingletonWithMetaLev
{-# INLINE varmpMetaLevSingleton #-}
-- (not yet) {-# DEPRECATED varmpSingleton "Use varlookupSingleton" #-}
-- | VarMp singleton
varmpSingleton :: Ord k => k -> v -> VarMp' k v
varmpSingleton = varlookupSingleton
{-# INLINE varmpSingleton #-}
assocMetaLevLToVarMp :: Ord k => AssocL k (MetaLev,v) -> VarMp' k v
assocMetaLevLToVarMp l = varmpUnions [ varlookupSingletonWithMetaLev lev k v | (k,(lev,v)) <- l ]
assocLToVarMp :: Ord k => AssocL k v -> VarMp' k v
assocLToVarMp = mkVarMp . Map.fromList
{-
assocMetaLevTyLToVarMp :: Ord k => AssocL k (MetaLev,Ty) -> VarMp' k VarMpInfo
assocMetaLevTyLToVarMp = assocMetaLevLToVarMp . assocLMapElt (\(ml,t) -> (ml, VMITy t)) -- varmpUnions [ varmpMetaLevTyUnit lev v t | (v,(lev,t)) <- l ]
assocTyLToVarMp :: Ord k => AssocL k Ty -> VarMp' k VarMpInfo
assocTyLToVarMp = assocLToVarMp . assocLMapElt VMITy
-}
varmpToAssocL :: VarMp' k i -> AssocL k i
varmpToAssocL (VarMp _ [] ) = []
varmpToAssocL (VarMp _ (l:_)) = Map.toList l
{-
varmpToAssocTyL :: VarMp' k VarMpInfo -> AssocL k Ty
varmpToAssocTyL c = [ (v,t) | (v,VMITy t) <- varmpToAssocL c ]
-}
-- VarMp: combine
infixr 7 `varmpPlus`
varmpPlus :: Ord k => VarMp' k v -> VarMp' k v -> VarMp' k v
varmpPlus = Lk.apply -- (|+>) -- (VarMp l1) (VarMp l2) = VarMp (l1 `Map.union` l2)
varmpUnion :: Ord k => VarMp' k v -> VarMp' k v -> VarMp' k v
varmpUnion = varmpPlus
varmpUnions :: Ord k => [VarMp' k v] -> VarMp' k v
varmpUnions [ ] = emptyVarMp
varmpUnions [x] = x
varmpUnions l = foldr1 varmpPlus l
-- | combine by taking the lowest level, adapting the lists with maps accordingly
varmpUnionWith :: Ord k => (v -> v -> v) -> VarMp' k v -> VarMp' k v -> VarMp' k v
varmpUnionWith f (VarMp l1 ms1) (VarMp l2 ms2)
= case compare l1 l2 of
EQ -> VarMp l1 (cmb ms1 ms2 )
LT -> VarMp l1 (cmb ms1 (replicate (l2 - l1) Map.empty ++ ms2))
GT -> VarMp l2 (cmb (replicate (l1 - l2) Map.empty ++ ms1) ms2 )
where cmb (m1:ms1) (m2:ms2) = Map.unionWith f m1 m2 : cmb ms1 ms2
cmb ms1 [] = ms1
cmb [] ms2 = ms2
-- Fold: map
varmpMapMaybe :: Ord k => (a -> Maybe b) -> VarMp' k a -> VarMp' k b
varmpMapMaybe f m = m {varmpMpL = map (Map.mapMaybe f) $ varmpMpL m}
varmpMap :: Ord k => (a -> b) -> VarMp' k a -> VarMp' k b
varmpMap f m = m {varmpMpL = map (Map.map f) $ varmpMpL m}
-- Insertion
varmpInsertWith :: Ord k => (v -> v -> v) -> k -> v -> VarMp' k v -> VarMp' k v
varmpInsertWith f k v = varmpUnionWith f (varmpSingleton k v)
-- Lookup as VarLookup
instance Ord k => VarLookup (VarMp' k v) where
varlookupWithMetaLev l k (VarMp vmlev ms) = lkup (l-vmlev) ms
where lkup _ [] = Nothing
lkup 0 (m:_) = Map.lookup k m
lkup l (_:ms) = lkup (l-1) ms
varlookup k vm@(VarMp vmlev _ ) = varlookupWithMetaLev vmlev k vm
varlookupKeysSetWithMetaLev l (VarMp vmlev ms) = Map.keysSet $ ms !! (l-vmlev)
varlookupKeysSet (VarMp _ ms) = Set.unions $ map Map.keysSet ms
varlookupEmpty = emptyVarMp
{-# INLINE varlookupEmpty #-}
varlookupSingletonWithMetaLev l k v = VarMp l [Map.singleton k v]
{-# INLINE varlookupSingletonWithMetaLev #-}
instance Ord k => LookupApply (VarMp' k v) (VarMp' k v) where
m1 `apply` m2 = varmpUnionWith const m1 m2
{-
instToL1VarMp :: [InstTo] -> VarMp
instToL1VarMp = varmpIncMetaLev . assocMetaLevTyLToVarMp . instToL1AssocL
-}
{-
data VarMpInfo
= VMITy !Ty
| VMIImpls !Impls
| VMIScope !PredScope
| VMIPred !Pred
| VMIAssNm !VarUIDHsName
| VMILabel !Label
| VMIOffset !LabelOffset
-- | VMIExts !RowExts
| VMIPredSeq !PredSeq
deriving
( Eq, Ord, Show
, Typeable, Data
)
vmiMbTy i = case i of {VMITy x -> Just x; _ -> Nothing}
vmiMbImpls i = case i of {VMIImpls x -> Just x; _ -> Nothing}
vmiMbScope i = case i of {VMIScope x -> Just x; _ -> Nothing}
vmiMbPred i = case i of {VMIPred x -> Just x; _ -> Nothing}
vmiMbAssNm i = case i of {VMIAssNm x -> Just x; _ -> Nothing}
vmiMbLabel i = case i of {VMILabel x -> Just x; _ -> Nothing}
vmiMbOffset i = case i of {VMIOffset x -> Just x; _ -> Nothing}
vmiMbPredSeq i = case i of {VMIPredSeq x -> Just x; _ -> Nothing}
type VarMp = VarMp' TyVarId VarMpInfo
-}
instance Show (VarMp' k v) where
show _ = "VarMp"
{-
varmpFilterTy :: Ord k => (k -> Ty -> Bool) -> VarMp' k VarMpInfo -> VarMp' k VarMpInfo
varmpFilterTy f
= varmpFilter
(\v i -> case i of {VMITy t -> f v t ; _ -> True})
varmpTailAddOcc :: ImplsProveOcc -> Impls -> (Impls,VarMp)
varmpTailAddOcc o (Impls_Tail i os) = (t, varmpImplsUnit i t)
where t = Impls_Tail i (o:os)
varmpTailAddOcc _ x = (x,emptyVarMp)
-}
{-
varmpMapThr :: (MetaLev -> TyVarId -> VarMpInfo -> thr -> (VarMpInfo,thr)) -> thr -> VarMp -> (VarMp,thr)
varmpMapThr f thr (VarMp l ms)
= (VarMp l ms',thr')
where (ms',thr') = foldMlev thr ms
foldMp mlev thr fm
= Map.foldrWithKey
(\v i (fm,thr)
-> let (i',thr') = f mlev v i thr
in (Map.insert v i' fm,thr')
)
(Map.empty,thr) fm
foldMlev thr ms
= foldr
(\(mlev,m) (ms,thr)
-> let (m',thr') = foldMp mlev thr m
in (m':ms,thr')
)
([],thr) (zip [0..] ms)
-}
{-
varmpMapThrTy :: (MetaLev -> TyVarId -> Ty -> thr -> (Ty,thr)) -> thr -> VarMp -> (VarMp,thr)
varmpMapThrTy f
= varmpMapThr
(\mlev v i thr
-> case i of
VMITy t -> (VMITy t,thr')
where (t',thr') = f mlev v t thr
_ -> (i,thr)
)
varmpinfoMkVar :: TyVarId -> VarMpInfo -> Ty
varmpinfoMkVar v i
= case i of
VMITy t -> mkTyVar v
VMIImpls i -> mkImplsVar v
_ -> mkTyVar v -- rest incomplete
varmpMetaLevTyUnit :: Ord k => MetaLev -> k -> Ty -> VarMp' k VarMpInfo
varmpMetaLevTyUnit mlev v t = varlookupSingletonWithMetaLev mlev v (VMITy t)
varmpTyUnit :: Ord k => k -> Ty -> VarMp' k VarMpInfo
varmpTyUnit = varmpMetaLevTyUnit metaLevVal
varmpImplsUnit :: ImplsVarId -> Impls -> VarMp
varmpImplsUnit v i = mkVarMp (Map.fromList [(v,VMIImpls i)])
varmpScopeUnit :: TyVarId -> PredScope -> VarMp
varmpScopeUnit v sc = mkVarMp (Map.fromList [(v,VMIScope sc)])
varmpPredUnit :: TyVarId -> Pred -> VarMp
varmpPredUnit v p = mkVarMp (Map.fromList [(v,VMIPred p)])
varmpAssNmUnit :: TyVarId -> VarUIDHsName -> VarMp
varmpAssNmUnit v p = mkVarMp (Map.fromList [(v,VMIAssNm p)])
assocImplsLToVarMp :: AssocL ImplsVarId Impls -> VarMp
assocImplsLToVarMp = mkVarMp . Map.fromList . assocLMapElt VMIImpls
varmpLabelUnit :: LabelVarId -> Label -> VarMp
varmpLabelUnit v l = mkVarMp (Map.fromList [(v,VMILabel l)])
varmpOffsetUnit :: UID -> LabelOffset -> VarMp
varmpOffsetUnit v l = mkVarMp (Map.fromList [(v,VMIOffset l)])
varmpPredSeqUnit :: TyVarId -> PredSeq -> VarMp
varmpPredSeqUnit v l = mkVarMp (Map.fromList [(v,VMIPredSeq l)])
-- restrict the kinds of tvars bound to value identifiers to kind *
tyRestrictKiVarMp :: [Ty] -> VarMp
tyRestrictKiVarMp ts = varmpIncMetaLev $ assocTyLToVarMp [ (v,kiStar) | t <- ts, v <- maybeToList $ tyMbVar t ]
-- | Encode 'ty' as a tvar + VarMp, with additional initial construction
tyAsVarMp' :: (UID -> Ty -> Ty) -> UID -> Ty -> (Ty,VarMp)
tyAsVarMp' f u t
= case f v1 t of
t | tyIsVar t -> (t, emptyVarMp)
| otherwise -> (mkTyVar v2, varmpTyUnit v2 t)
where [v1,v2] = mkNewLevUIDL 2 u
-- | Encode 'ty' as a tvar + VarMp
tyAsVarMp :: UID -> Ty -> (Ty,VarMp)
tyAsVarMp = tyAsVarMp' (flip const)
-}
varmpLookup :: (VarLookup m, Ord (VarLookupKey m)) => VarLookupKey m -> m -> Maybe (VarLookupVal m)
varmpLookup = varlookup -- varlookupMap (Just . id)
{-# INLINE varmpLookup #-}
{-
varmpTyLookup :: (VarLookup m k VarMpInfo,Ord k) => k -> m -> Maybe Ty
varmpTyLookup = varlookupMap vmiMbTy
varmpImplsLookup :: VarLookup m ImplsVarId VarMpInfo => ImplsVarId -> m -> Maybe Impls
varmpImplsLookup = varlookupMap vmiMbImpls
varmpScopeLookup :: VarLookup m TyVarId VarMpInfo => TyVarId -> m -> Maybe PredScope
varmpScopeLookup = varlookupMap vmiMbScope
varmpPredLookup :: VarLookup m TyVarId VarMpInfo => TyVarId -> m -> Maybe Pred
varmpPredLookup = varlookupMap vmiMbPred
varmpAssNmLookup :: VarLookup m TyVarId VarMpInfo => TyVarId -> m -> Maybe VarUIDHsName
varmpAssNmLookup = varlookupMap vmiMbAssNm
varmpLabelLookup :: VarLookup m LabelVarId VarMpInfo => LabelVarId -> m -> Maybe Label
varmpLabelLookup = varlookupMap vmiMbLabel
varmpOffsetLookup :: VarLookup m UID VarMpInfo => UID -> m -> Maybe LabelOffset
varmpOffsetLookup = varlookupMap vmiMbOffset
varmpPredSeqLookup :: VarLookup m TyVarId VarMpInfo => TyVarId -> m -> Maybe PredSeq
varmpPredSeqLookup = varlookupMap vmiMbPredSeq
varmpTyLookupCyc :: VarLookup m TyVarId VarMpInfo => TyVarId -> m -> Maybe Ty
varmpTyLookupCyc x m = lookupLiftCycMb2 tyMbVar (flip varmpTyLookup m) x
varmpImplsLookupImplsCyc :: VarLookup m ImplsVarId VarMpInfo => Impls -> m -> Maybe Impls
varmpImplsLookupImplsCyc x m = lookupLiftCycMb1 implsMbVar (flip varmpImplsLookup m) x
varmpImplsLookupCyc :: VarLookup m ImplsVarId VarMpInfo => TyVarId -> m -> Maybe Impls
varmpImplsLookupCyc x m = lookupLiftCycMb2 implsMbVar (flip varmpImplsLookup m) x
varmpScopeLookupScopeCyc :: VarLookup m ImplsVarId VarMpInfo => PredScope -> m -> Maybe PredScope
varmpScopeLookupScopeCyc x m = lookupLiftCycMb1 pscpMbVar (flip varmpScopeLookup m) x
varmpAssNmLookupAssNmCyc :: VarLookup m ImplsVarId VarMpInfo => VarUIDHsName -> m -> Maybe VarUIDHsName
varmpAssNmLookupAssNmCyc x m = lookupLiftCycMb1 vunmMbVar (flip varmpAssNmLookup m) x
varmpLabelLookupLabelCyc :: VarLookup m ImplsVarId VarMpInfo => Label -> m -> Maybe Label
varmpLabelLookupLabelCyc x m = lookupLiftCycMb1 labelMbVar (flip varmpLabelLookup m) x
varmpLabelLookupCyc :: VarLookup m ImplsVarId VarMpInfo => TyVarId -> m -> Maybe Label
varmpLabelLookupCyc x m = lookupLiftCycMb2 labelMbVar (flip varmpLabelLookup m) x
varmpTyLookupCyc2 :: VarMp -> TyVarId -> Maybe Ty
varmpTyLookupCyc2 x m = varmpTyLookupCyc m x
varmpScopeLookup2 :: VarMp -> TyVarId -> Maybe PredScope
varmpScopeLookup2 m v = varmpScopeLookup v m
varmpImplsLookup2 :: VarMp -> ImplsVarId -> Maybe Impls
varmpImplsLookup2 m v = varmpImplsLookup v m
varmpImplsLookupCyc2 :: VarMp -> ImplsVarId -> Maybe Impls
varmpImplsLookupCyc2 m v = varmpImplsLookupCyc v m
varmpPredLookup2 :: VarMp -> TyVarId -> Maybe Pred
varmpPredLookup2 m v = varmpPredLookup v m
varmpAssNmLookup2 :: VarMp -> TyVarId -> Maybe VarUIDHsName
varmpAssNmLookup2 m v = varmpAssNmLookup v m
varmpLabelLookup2 :: VarMp -> LabelVarId -> Maybe Label
varmpLabelLookup2 m v = varmpLabelLookup v m
-}
-- VarMp stack, for nested/local behavior
{-
newtype VarMpStk' k v
= VarMpStk [VarMp' k v]
deriving (Show)
emptyVarMpStk :: VarMpStk' k v
emptyVarMpStk = VarMpStk [emptyVarMp]
varmpstkUnit :: Ord k => k -> v -> VarMpStk' k v
varmpstkUnit k v = VarMpStk [mkVarMp (Map.fromList [(k,v)])]
varmpstkPushEmpty :: VarMpStk' k v -> VarMpStk' k v
varmpstkPushEmpty (VarMpStk s) = VarMpStk (emptyVarMp : s)
varmpstkPop :: VarMpStk' k v -> (VarMpStk' k v, VarMpStk' k v)
varmpstkPop (VarMpStk (s:ss)) = (VarMpStk [s], VarMpStk ss)
varmpstkPop _ = panic "varmpstkPop: empty"
varmpstkToAssocL :: VarMpStk' k v -> AssocL k v
varmpstkToAssocL (VarMpStk s) = concatMap varmpToAssocL s
varmpstkKeysSet :: Ord k => VarMpStk' k v -> Set.Set k
varmpstkKeysSet (VarMpStk s) = Set.unions $ map varmpKeysSet s
varmpstkUnions :: Ord k => [VarMpStk' k v] -> VarMpStk' k v
varmpstkUnions [x] = x
varmpstkUnions l = foldr (|+>) emptyVarMpStk l
instance Ord k => VarLookup (VarMpStk' k v) k v where
varlookupWithMetaLev l k (VarMpStk s) = varlookupWithMetaLev l k s
instance Ord k => VarLookupCmb (VarMpStk' k v) (VarMpStk' k v) where
(VarMpStk s1) |+> (VarMpStk s2) = VarMpStk (s1 |+> s2)
-}
-- Pretty printing
ppVarMpV :: (PP k, PP v) => VarMp' k v -> PP_Doc
ppVarMpV = ppVarMp vlist
ppVarMp :: (PP k, PP v) => ([PP_Doc] -> PP_Doc) -> VarMp' k v -> PP_Doc
ppVarMp ppL (VarMp mlev ms)
= ppL [ "@" >|< pp lev >|< ":" >#< ppL [ pp n >|< ":->" >|< pp v | (n,v) <- Map.toList m]
| (lev,m) <- zip [mlev..] ms
]
instance (PP k, PP v) => PP (VarMp' k v) where
pp = ppVarMp (ppCommas')
{-
instance (PP k, PP v) => PP (VarMpStk' k v) where
pp (VarMpStk s) = ppSemis' $ map pp s
-}
{-
ppVarMpInfoCfgTy :: CfgPPTy -> VarMpInfo -> PP_Doc
ppVarMpInfoCfgTy c i
= case i of
VMITy t -> ppTyWithCfg c t
VMIImpls i -> ppImplsWithCfg c i
VMIScope s -> pp s -- rest incomplete
VMIPred p -> pp p
VMILabel x -> pp x
VMIOffset x -> pp x
VMIPredSeq x -> pp "predseq" -- pp x
ppVarMpInfoDt :: VarMpInfo -> PP_Doc
ppVarMpInfoDt = ppVarMpInfoCfgTy cfgPPTyDT
instance PP VarMpInfo where
pp (VMITy t) = pp t
pp (VMIImpls i) = pp i
pp (VMIScope s) = pp s
pp (VMIPred p) = pp p
pp (VMILabel x) = pp x
pp (VMIOffset x) = pp x
-- pp (VMIExts x) = pp "exts" -- pp x
pp (VMIPredSeq x) = pp "predseq" -- pp x
instance Serialize VarMpInfo where
sput (VMITy a) = sputWord8 0 >> sput a
sput (VMIImpls a) = sputWord8 1 >> sput a
sput (VMIScope a) = sputWord8 2 >> sput a
sput (VMIPred a) = sputWord8 3 >> sput a
sput (VMIAssNm a) = sputWord8 4 >> sput a
sput (VMILabel a) = sputWord8 5 >> sput a
sput (VMIOffset a) = sputWord8 6 >> sput a
sput (VMIPredSeq a) = sputWord8 7 >> sput a
sget = do t <- sgetWord8
case t of
0 -> liftM VMITy sget
1 -> liftM VMIImpls sget
2 -> liftM VMIScope sget
3 -> liftM VMIPred sget
4 -> liftM VMIAssNm sget
5 -> liftM VMILabel sget
6 -> liftM VMIOffset sget
7 -> liftM VMIPredSeq sget
-}
{-
instance (Ord k, Serialize k, Serialize v) => Serialize (VarMp' k v) where
-- sput (VarMp a b) = sput a >> sput b
-- sget = liftM2 VarMp sget sget
-}