Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

mods for factoring out to uhc-util 0.1.1

  • Loading branch information...
commit fa2194f09d6fceb1fc3cc528602633199e45ca37 1 parent 7ebdf07
@atzedijkstra atzedijkstra authored
View
2  EHC/configure
@@ -3798,7 +3798,7 @@ HADDOCK_VERSION=$haddockVersion
# GHC version dependencies: packages passed as option, cabal packages
-cabal_base_lib_depends="base mtl fgl directory hashable uhc-util"
+cabal_base_lib_depends="base mtl fgl directory hashable uhc-util>=0.1.1"
if test x$enableClr = "xyes"
then
cabal_base_lib_depends="$cabal_base_lib_depends language-cil"
View
2  EHC/configure.ac
@@ -415,7 +415,7 @@ AC_SUBST(HADDOCK_CMD,$haddockCmd)
AC_SUBST(HADDOCK_VERSION, $haddockVersion)
# GHC version dependencies: packages passed as option, cabal packages
-cabal_base_lib_depends="base mtl fgl directory hashable uhc-util"
+cabal_base_lib_depends="base mtl fgl directory hashable uhc-util>=0.1.1"
if test x$enableClr = "xyes"
then
cabal_base_lib_depends="$cabal_base_lib_depends language-cil"
View
70 EHC/src/ehc/Base/AssocL.chs
@@ -10,73 +10,9 @@
%%[1 module {%{EH}Base.AssocL}
%%]
-%%[1 import(UHC.Util.Pretty, UHC.Util.Utils)
-%%]
-%%[1 import(Data.List)
-%%]
-
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-%%% AssocL
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-%%[1.AssocL export(Assoc,AssocL)
-type Assoc k v = (k,v)
-type AssocL k v = [Assoc k v]
-%%]
-
-%%[1.ppAssocL export(ppAssocL)
-ppAssocL :: (PP k, PP v) => AssocL k v -> PP_Doc
-ppAssocL al = ppListSepFill "[ " " ]" ", " (map (\(k,v) -> pp k >|< ":" >|< pp v) al)
-%%]
-
-%%[8.ppAssocL -1.ppAssocL export(ppAssocL,ppAssocL',ppAssocLV)
-ppAssocL' :: (PP k, PP v, PP s) => ([PP_Doc] -> PP_Doc) -> s -> AssocL k v -> PP_Doc
-ppAssocL' ppL sep al = ppL (map (\(k,v) -> pp k >|< sep >#< pp v) al)
-
-ppAssocL :: (PP k, PP v) => AssocL k v -> PP_Doc
-ppAssocL = ppAssocL' (ppBlock "[" "]" ",") ":"
-
-ppAssocLV :: (PP k, PP v) => AssocL k v -> PP_Doc
-ppAssocLV = ppAssocL' vlist ":"
+%%[1 import(UHC.Util.AssocL) export(module UHC.Util.AssocL)
%%]
-%%[50 export(ppCurlysAssocL)
--- intended for parsing
-ppCurlysAssocL :: (k -> PP_Doc) -> (v -> PP_Doc) -> AssocL k v -> PP_Doc
-ppCurlysAssocL pk pv = ppCurlysCommasBlock . map (\(k,v) -> pk k >#< "=" >#< pv v)
+%%[1
+-- module is moved to uhc-util package
%%]
-
-%%[1 export(assocLMapElt,assocLMapKey)
-assocLMap :: (k -> v -> (k',v')) -> AssocL k v -> AssocL k' v'
-assocLMap f = map (uncurry f)
-{-# INLINE assocLMap #-}
-
-assocLMapElt :: (v -> v') -> AssocL k v -> AssocL k v'
-assocLMapElt f = assocLMap (\k v -> (k,f v))
-{-# INLINE assocLMapElt #-}
-
-assocLMapKey :: (k -> k') -> AssocL k v -> AssocL k' v
-assocLMapKey f = assocLMap (\k v -> (f k,v))
-{-# INLINE assocLMapKey #-}
-%%]
-
-%%[4 export(assocLMapUnzip)
-assocLMapUnzip :: AssocL k (v1,v2) -> (AssocL k v1,AssocL k v2)
-assocLMapUnzip l = unzip [ ((k,v1),(k,v2)) | (k,(v1,v2)) <- l ]
-%%]
-
-%%[1 export(assocLElts,assocLKeys)
-assocLKeys :: AssocL k v -> [k]
-assocLKeys = map fst
-{-# INLINE assocLKeys #-}
-
-assocLElts :: AssocL k v -> [v]
-assocLElts = map snd
-{-# INLINE assocLElts #-}
-%%]
-
-%%[1 export(assocLGroupSort)
-assocLGroupSort :: Ord k => AssocL k v -> AssocL k [v]
-assocLGroupSort = map (foldr (\(k,v) (_,vs) -> (k,v:vs)) (panic "Base.Common.assocLGroupSort" ,[])) . groupSortOn fst
-%%]
-
View
8 EHC/src/ehc/Base/Common.chs
@@ -1085,13 +1085,7 @@ rowCanonOrderBy cmp = sortByOn cmp fst
%%% Meta levels
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-%%[2 hs export(MetaLev)
-type MetaLev = Int
-%%]
-
-%%[4 hs export(metaLevVal)
-metaLevVal :: MetaLev
-metaLevVal = 0
+%%[2 hs import(UHC.Util.VarLookup(MetaLev,metaLevVal)) export(MetaLev,metaLevVal)
%%]
%%[6 hs export(metaLevTy, metaLevKi, metaLevSo)
View
246 EHC/src/ehc/Gam/ScopeMapGam.chs
@@ -30,12 +30,10 @@ Conceptually thus the invariant is that no entry is in the map which is not in s
%%[8 import(qualified Data.Set as Set,qualified Data.Map as Map,Data.Maybe,Data.List)
%%]
-%%[8 import({%{EH}VarMp})
-%%]
-%%[8 import(UHC.Util.Utils)
+%%[8 import(UHC.Util.ScopeMapGam) export(module UHC.Util.ScopeMapGam)
%%]
-%%[8 import({%{EH}Base.Common})
+%%[50 import({%{EH}VarMp})
%%]
%%[50 hs import(Data.Typeable(Typeable), Data.Generics(Data), {%{EH}Base.Serialize})
@@ -43,246 +41,6 @@ Conceptually thus the invariant is that no entry is in the map which is not in s
%%[50 import(Control.Monad, {%{EH}Base.Binary})
%%]
-%%[9999 import({%{EH}Base.ForceEval})
-%%]
-
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-%%% Debug
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-%%[9999 import(UHC.Util.Debug)
-%%]
-
-%%[9
-%%]
-tr _ _ x = x
-
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-%%% Scope Gam, a Gam with entries having a level in a scope, and the Gam a scope
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-%%[8 export(SGam,emptySGam)
-type Scp = [Int] -- a stack of scope idents defines what's in scope
-
-data SGamElt v
- = SGamElt
- { sgeScpId :: !Int -- scope ident
- , sgeVal :: v -- the value
- }
-%%[[50
- deriving (Typeable, Data)
-%%]]
-
--- type SMap k v = Map.Map k [SGamElt v]
-type SMap k v = VarMp' k [SGamElt v]
-
-emptySMap :: SMap k v
-emptySMap = emptyVarMp
-
-data SGam k v
- = SGam
- { sgScpId :: !Int -- current scope, increment with each change in scope
- , sgScp :: !Scp -- scope stack
- , sgMap :: SMap k v -- map holding the values
- }
-%%[[50
- deriving (Typeable, Data)
-%%]]
-
-mkSGam :: SMap k v -> SGam k v
-mkSGam = SGam 0 [0]
-
-emptySGam :: SGam k v
-emptySGam = mkSGam emptySMap
-
-instance Show (SGam k v) where
- show _ = "SGam"
-
-%%]
-
-%%[8
--- scope ident in scope?
-inScp :: Scp -> Int -> Bool
-inScp = flip elem
-{-# INLINE inScp #-}
-
--- sgam elt in scope?
-sgameltInScp :: Scp -> SGamElt v -> Bool
-sgameltInScp scp = inScp scp . sgeScpId
-{-# INLINE sgameltInScp #-}
-%%]
-
-%%[8
--- filter out the out of scopes
-sgameltFilterInScp :: Scp -> [SGamElt v] -> [SGamElt v]
-sgameltFilterInScp scp = filter (sgameltInScp scp)
-{-# INLINE sgameltFilterInScp #-}
-
--- map the in scopes
-sgameltMapInScp :: Scp -> (v -> v) -> [SGamElt v] -> [SGamElt v]
-sgameltMapInScp scp f = map (\e -> if sgameltInScp scp e then e {sgeVal = f (sgeVal e)} else e)
-{-# INLINE sgameltMapInScp #-}
-
--- extract the in scopes
-sgameltGetFilterInScp :: Scp -> (v -> v') -> [SGamElt v] -> [v']
-sgameltGetFilterInScp scp f es = [ f (sgeVal e) | e <- es, sgameltInScp scp e ]
-{-# INLINE sgameltGetFilterInScp #-}
-%%]
-
-%%[8
--- filter out the out of scopes, applying a mapping function on the fly
-mapFilterInScp' :: Ord k => Scp -> ([SGamElt v] -> [SGamElt v]) -> SMap k v -> SMap k v
-mapFilterInScp' scp f m
- = varmpMapMaybe (\es -> maybeNull Nothing (Just . f) $ sgameltFilterInScp scp es) m
-{-# INLINE mapFilterInScp' #-}
-
-mapFilterInScp :: Ord k => Scp -> (SGamElt v -> SGamElt v) -> SMap k v -> SMap k v
-mapFilterInScp scp f m
- = mapFilterInScp' scp (map f) m
-{-# INLINE mapFilterInScp #-}
-
-sgamFilterInScp :: Ord k => SGam k v -> SGam k v
-sgamFilterInScp g@(SGam {sgScp = scp, sgMap = m})
- = g {sgMap = mapFilterInScp scp id m}
-{-# INLINE sgamFilterInScp #-}
-%%]
-
-%%[8 export(sgamFilterMapEltAccumWithKey,sgamMapEltWithKey,sgamMapThr,sgamMap)
--- do it all: map, filter, fold
-sgamFilterMapEltAccumWithKey
- :: (Ord k')
- => (k -> SGamElt v -> Bool)
- -> (k -> SGamElt v -> acc -> (k',SGamElt v',acc))
- -> (k -> SGamElt v -> acc -> acc)
- -> acc -> SGam k v -> (SGam k' v',acc)
-sgamFilterMapEltAccumWithKey p fyes fno a g
- = (g {sgMap = mkVarMp m'},a')
- where (m,_) = varmpAsMap (sgMap g)
- (m',a') = Map.foldrWithKey
- (\k es ma@(m,a)
- -> foldr (\e (m,a)
- -> if p k e
- then let (k',e',a') = fyes k e a
- in (Map.insertWith (++) k' [e'] m,a')
- else (m,fno k e a)
- ) ma
- $ sgameltFilterInScp (sgScp g) es
- ) (Map.empty,a) m
-
-sgamMapEltWithKey :: (Ord k,Ord k') => (k -> SGamElt v -> (k',SGamElt v')) -> SGam k v -> SGam k' v'
-sgamMapEltWithKey f g
- = g'
- where (g',_) = sgamFilterMapEltAccumWithKey (\_ _ -> True) (\k e a -> let (k',e') = f k e in (k',e',a)) undefined () g
-
-sgamMapThr :: (Ord k,Ord k') => ((k,v) -> t -> ((k',v'),t)) -> t -> SGam k v -> (SGam k' v',t)
-sgamMapThr f thr g = sgamFilterMapEltAccumWithKey (\_ _ -> True) (\k e thr -> let ((k',v'),thr') = f (k,sgeVal e) thr in (k',e {sgeVal = v'},thr')) undefined thr g
-
-sgamMap :: (Ord k,Ord k') => ((k,v) -> (k',v')) -> SGam k v -> SGam k' v'
-sgamMap f g = sgamMapEltWithKey (\k e -> let (k',v') = f (k,sgeVal e) in (k',e {sgeVal = v'})) g
-%%]
-
-%%[8 export(sgamMetaLevSingleton,sgamSingleton)
-sgamMetaLevSingleton :: MetaLev -> k -> v -> SGam k v
-sgamMetaLevSingleton mlev k v = mkSGam (varmpMetaLevSingleton mlev k [SGamElt 0 v])
-
-sgamSingleton :: k -> v -> SGam k v
-sgamSingleton = sgamMetaLevSingleton metaLevVal
-%%]
-
-%%[8 export(sgamUnionWith,sgamUnion)
--- combine gam, g1 is added to g2 with scope of g2
-sgamUnionWith :: Ord k => Maybe (v -> [v] -> [v]) -> SGam k v -> SGam k v -> SGam k v
-sgamUnionWith cmb g1@(SGam {sgScp = scp1, sgMap = m1}) g2@(SGam {sgScp = scp2@(hscp2:_), sgMap = m2})
- = g2 {sgMap = varmpUnionWith cmb' m1' m2}
- where m1' = mapFilterInScp scp1 (\e -> e {sgeScpId = hscp2}) m1
- cmb' = maybe (++)
- (\c -> \l1 l2 -> concat [ map (SGamElt scp) $ foldr c [] $ map sgeVal g | g@(SGamElt {sgeScpId = scp} : _) <- groupSortOn sgeScpId $ l1 ++ l2 ])
- cmb
-
--- combine gam, g1 is added to g2 with scope of g2
-sgamUnion :: Ord k => SGam k v -> SGam k v -> SGam k v
-sgamUnion = sgamUnionWith Nothing
-{-# INLINE sgamUnion #-}
-%%]
-
-%%[8 export(sgamPartitionEltWithKey,sgamPartitionWithKey)
--- equivalent of partition
-sgamPartitionEltWithKey :: Ord k => (k -> SGamElt v -> Bool) -> SGam k v -> (SGam k v,SGam k v)
-sgamPartitionEltWithKey p g
- = (g1, SGam (sgScpId g1) (sgScp g1) m2)
- where (g1,m2) = sgamFilterMapEltAccumWithKey p (\k e a -> (k,e,a)) (\k e a -> varmpInsertWith (++) k [e] a) emptySMap g
-
-sgamPartitionWithKey :: Ord k => (k -> v -> Bool) -> SGam k v -> (SGam k v,SGam k v)
-sgamPartitionWithKey p = sgamPartitionEltWithKey (\k e -> p k (sgeVal e))
-%%]
-
-%%[8 export(sgamUnzip)
--- equivalent of unzip
-sgamUnzip :: Ord k => SGam k (v1,v2) -> (SGam k v1,SGam k v2)
-sgamUnzip g
- = (g1, g1 {sgMap = m2})
- where (g1,m2) = sgamFilterMapEltAccumWithKey (\_ _ -> True) (\k e@(SGamElt {sgeVal = (v1,v2)}) m -> (k,e {sgeVal = v1},varmpInsertWith (++) k [e {sgeVal = v2}] m)) undefined emptySMap g
-%%]
-
-%%[8 export(sgamPop,sgamTop)
--- split gam in top and the rest, both with the same scope
-sgamPop :: Ord k => SGam k v -> (SGam k v, SGam k v)
-sgamPop g@(SGam {sgMap = m, sgScpId = scpId, sgScp = scp@(hscp:tscp)})
- = (SGam scpId [hscp] m, SGam scpId tscp m)
- -- = (sgamFilterInScp $ SGam scpId [hscp] m, sgamFilterInScp $ SGam scpId tscp m)
-
--- top gam, with same scope as g
-sgamTop :: Ord k => SGam k v -> SGam k v
-sgamTop g
- = fst $ sgamPop g
-%%]
-
-%%[8 export(sgamPushNew,sgamPushGam)
--- enter a new scope
-sgamPushNew :: SGam k v -> SGam k v
-sgamPushNew g
- = g {sgScpId = si, sgScp = si : sgScp g}
- where si = sgScpId g + 1
-
--- enter a new scope, add g1 in that scope to g2
-sgamPushGam :: Ord k => SGam k v -> SGam k v -> SGam k v
-sgamPushGam g1 g2 = g1 `sgamUnion` sgamPushNew g2
-%%]
-
-%%[8 export(sgamLookupMetaLevDup)
--- lookup, return at least one found value, otherwise Nothing
-sgamLookupMetaLevDup :: Ord k => MetaLev -> k -> SGam k v -> Maybe [v]
-sgamLookupMetaLevDup mlev k g@(SGam {sgMap = m, sgScpId = scpId, sgScp = scp})
- = case varlookupWithMetaLev mlev k m of
- Just es | not (null vs)
- -> Just vs
- where vs = {- map sgeVal es -- -} sgameltGetFilterInScp scp id es
- _ -> Nothing
-%%]
--- lookup, return at least one found value, otherwise Nothing
-sgamLookupDup :: Ord k => k -> SGam k v -> Maybe [v]
-sgamLookupDup = sgamLookupMetaLevDup metaLevVal
-
-%%[8 export(sgamToAssocDupL,sgamFromAssocDupL)
--- convert to association list, with all duplicates, scope is lost
-sgamToAssocDupL :: Ord k => SGam k v -> AssocL k [v]
-sgamToAssocDupL g@(SGam {sgScp = scp, sgMap = m})
- = varmpToAssocL $ varmpMap (map sgeVal) $ sgMap $ sgamFilterInScp g
-
--- convert from association list, assume default scope
-sgamFromAssocDupL :: Ord k => AssocL k [v] -> SGam k v
-sgamFromAssocDupL l
- = mkSGam m
- where m = varmpMap (map (SGamElt 0)) $ assocLToVarMp l
-%%]
-
-%%[8 export(sgamNoDups)
--- get rid of duplicate entries, by taking the first of them all
-sgamNoDups :: Ord k => SGam k v -> SGam k v
-sgamNoDups g@(SGam {sgScp = scp, sgMap = m})
- = g {sgMap = mapFilterInScp' scp (\(e:_) -> [e]) m}
-%%]
-
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% Instances: Binary, Serialize
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
View
107 EHC/src/ehc/VarLookup.chs
@@ -2,120 +2,19 @@
%%% Abstraction for looking up something for a variable
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-%%[(6 hmtyinfer || hmtyast) module {%{EH}VarLookup} import({%{EH}Base.Common})
+%%[(6 hmtyinfer || hmtyast) module {%{EH}VarLookup}
%%]
-%%[(6 hmtyinfer || hmtyast) import(Data.Maybe)
+%%[(6 hmtyinfer || hmtyast) import(UHC.Util.VarLookup) export(module UHC.Util.VarLookup)
%%]
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% VarLookup
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-%%[doesWhat doclatex
-VarLookup abstracts from a Map.
-The purpose is to be able to combine maps only for the purpose of searching without actually merging the maps.
-This then avoids the later need to unmerge such mergings.
-The class interface serves to hide this.
-%%]
-
-%%[(6 hmtyinfer || hmtyast) export(VarLookup(..))
-class VarLookup m k v where
- varlookupWithMetaLev :: MetaLev -> k -> m -> Maybe v
- varlookup :: k -> m -> Maybe v
-
- -- defaults
- varlookup = varlookupWithMetaLev 0
-%%]
-
-%%[(6 hmtyinfer || hmtyast)
-instance (VarLookup m1 k v,VarLookup m2 k v) => VarLookup (m1,m2) k v where
- varlookupWithMetaLev l k (m1,m2)
- = case varlookupWithMetaLev l k m1 of
- r@(Just _) -> r
- _ -> varlookupWithMetaLev l k m2
-
-instance VarLookup m k v => VarLookup [m] k v where
- varlookupWithMetaLev l k ms = listToMaybe $ catMaybes $ map (varlookupWithMetaLev l k) ms
-%%]
-
-%%[(6 hmtyinfer || hmtyast) export(varlookupMap)
-varlookupMap :: VarLookup m k v => (v -> Maybe res) -> k -> m -> Maybe res
-varlookupMap get k m
- = do { v <- varlookup k m
- ; get v
- }
-%%]
-
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-%%% Utils: fixed lookup
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-%%[(6 hmtyinfer || hmtyast) export(VarLookupFix, varlookupFix)
-type VarLookupFix k v = k -> Maybe v
-
--- | fix looking up to be for a certain var mapping
-varlookupFix :: VarLookup m k v => m -> VarLookupFix k v
-varlookupFix m = \k -> varlookup k m
-%%]
-
-%%[(6 hmtyinfer || hmtyast) export(varlookupFixDel)
--- | simulate deletion
-varlookupFixDel :: Ord k => [k] -> VarLookupFix k v -> VarLookupFix k v
-varlookupFixDel ks f = \k -> if k `elem` ks then Nothing else f k
-%%]
-
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-%%% VarLookupCmb
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-%%[doesWhat doclatex
-VarLookupCmb abstracts the 'combining' of/from a substitution.
-The interface goes along with VarLookup but is split off to avoid functional dependency restrictions.
-The purpose is to be able to combine maps only for the purpose of searching without actually merging the maps.
-This then avoids the later need to unmerge such mergings.
-%%]
-
-%%[(6 hmtyinfer || hmtyast)
-infixr 7 |+>
-%%]
-
-%%[(6 hmtyinfer || hmtyast) export(VarLookupCmb(..))
-class VarLookupCmb m1 m2 where
- (|+>) :: m1 -> m2 -> m2
-%%]
-
%%[(6 hmtyinfer || hmtyast)
-instance VarLookupCmb m1 m2 => VarLookupCmb m1 [m2] where
- m1 |+> (m2:m2s) = (m1 |+> m2) : m2s
-
-instance (VarLookupCmb m1 m1, VarLookupCmb m1 m2) => VarLookupCmb [m1] [m2] where
- m1 |+> (m2:m2s) = (foldr1 (|+>) m1 |+> m2) : m2s
-%%]
-
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-%%% VarLookupBase
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-%%[doesWhat doclatex
-VarLookupBase abstracts over base info for a structure representing lookup.
-%%]
-
-%%[(6 hmtyinfer || hmtyast) export(VarLookupBase(..))
-class VarLookupBase m k v | m -> k v where
- varlookupEmpty :: m
- -- varlookupTyUnit :: k -> v -> m
+-- moved to uhc-util package
%%]
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-%%% Utils: fixed combine
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-%%[(6 hmtyinfer || hmtyast) export(VarLookupCmbFix, varlookupcmbFix)
-type VarLookupCmbFix m1 m2 = m1 -> m2 -> m2
-
--- | fix combining up to be for a certain var mapping
-varlookupcmbFix :: VarLookupCmb m1 m2 => VarLookupCmbFix m1 m2
-varlookupcmbFix m1 m2 = m1 |+> m2
-%%]
View
243 EHC/src/ehc/VarMp.chs
@@ -35,13 +35,7 @@ A multiple level VarMp knows its own absolute metalevel, which is the default to
%%[2 import(qualified Data.Map as Map,qualified Data.Set as Set,Data.Maybe)
%%]
-%%[2 import(UHC.Util.Pretty, {%{EH}Ty.Pretty}) export(ppVarMpV)
-%%]
-
-%%[4 export(varmpFilterTy,varmpDel,(|\>))
-%%]
-
-%%[4
+%%[2 import(UHC.Util.Pretty, {%{EH}Ty.Pretty})
%%]
%%[4 import({%{EH}Error})
@@ -53,6 +47,9 @@ A multiple level VarMp knows its own absolute metalevel, which is the default to
%%[(4_2) export(tyAsVarMp',varmpTyRevUnit)
%%]
+%%[6 import(UHC.Util.VarMp) export(module UHC.Util.VarMp)
+%%]
+
%%[6 import({%{EH}VarLookup}) export(module {%{EH}VarLookup})
%%]
@@ -77,27 +74,7 @@ newtype VarMp' k v = VarMp (AssocL k v) deriving Show
%%]
%%[6 -2.VarMpQ.Base
-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
-%%[[50
- , Typeable, Data
-%%]]
- )
-%%]
-
-%%[99 export(varmpToMap)
--- get the base meta level map, ignore the others
-varmpToMap :: VarMp' k v -> Map.Map k v
-varmpToMap (VarMp _ (m:_)) = m
-%%]
-
-%%[6 export(mkVarMp)
-mkVarMp :: Map.Map k v -> VarMp' k v
-mkVarMp m = VarMp 0 [m]
+-- moved to package uhc-util
%%]
%%[2.VarMp.emptyVarMp export(emptyVarMp)
@@ -105,15 +82,7 @@ emptyVarMp :: VarMp' k v
emptyVarMp = VarMp []
%%]
-%%[6.VarMp.emptyVarMp -2.VarMp.emptyVarMp export(emptyVarMp,varmpIsEmpty)
-emptyVarMp :: VarMp' k v
-emptyVarMp = mkVarMp Map.empty
-
-varmpIsEmpty :: VarMp' k v -> Bool
-varmpIsEmpty (VarMp {varmpMpL=l}) = all Map.null l
-
-instance VarLookupBase (VarMp' k v) k v where
- varlookupEmpty = emptyVarMp
+%%[6.VarMp.emptyVarMp -2.VarMp.emptyVarMp
%%]
%%[4.varmpFilter export(varmpFilter)
@@ -127,13 +96,6 @@ varmpPartition f (VarMp l)
%%]
%%[6.varmpFilter -4.varmpFilter
-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
%%]
%%[4.varmpDel
@@ -144,50 +106,13 @@ varmpDel tvL c = varmpFilter (const.not.(`elem` tvL)) c
(|\>) = flip varmpDel
%%]
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-%%% VarMp: meta level changes
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-%%[6 export(varmpShiftMetaLev,varmpIncMetaLev,varmpDecMetaLev)
--- 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)
-%%]
-
-%%[6 export(varmpSelectMetaLev)
-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 ])
-%%]
-
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-%%% VarMp: destruction
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-%%[8 export(varmpAsMap)
--- | 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))
+%%[6.varmpDel -4.varmpDel
%%]
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% VarMp: properties
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-%%[9 export(varmpSize)
-varmpSize :: VarMp' k v -> Int
-varmpSize (VarMp _ m) = sum $ map Map.size m
-%%]
-
%%[4.varmpKeys export(varmpKeys,varmpKeysSet)
varmpKeys :: VarMp' k v -> [k]
varmpKeys (VarMp l) = assocLKeys l
@@ -196,12 +121,7 @@ varmpKeysSet :: Ord k => VarMp' k v -> Set.Set k
varmpKeysSet = Set.fromList . varmpKeys
%%]
-%%[6.varmpKeys -4.varmpKeys export(varmpKeys,varmpKeysSet)
-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
+%%[6.varmpKeys -4.varmpKeys
%%]
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -213,12 +133,7 @@ varmpSingleton :: k -> v -> VarMp' k v
varmpSingleton tv t = VarMp [(tv,t)]
%%]
-%%[6.VarMp.varmpSingleton -2.VarMp.varmpSingleton export(varmpMetaLevSingleton,varmpSingleton)
-varmpMetaLevSingleton :: MetaLev -> k -> v -> VarMp' k v
-varmpMetaLevSingleton mlev k v = VarMp mlev [Map.singleton k v]
-
-varmpSingleton :: k -> v -> VarMp' k v
-varmpSingleton = varmpMetaLevSingleton metaLevVal
+%%[6.VarMp.varmpSingleton -2.VarMp.varmpSingleton
%%]
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -237,23 +152,13 @@ varmpToAssocL :: VarMp' k v -> AssocL k v
varmpToAssocL = varmpToAssocTyL
%%]
-%%[6.assocTyLToVarMp -4.assocTyLToVarMp export(assocMetaLevLToVarMp,assocLToVarMp,assocMetaLevTyLToVarMp,assocTyLToVarMp,varmpToAssocTyL,varmpToAssocL)
-assocMetaLevLToVarMp :: Ord k => AssocL k (MetaLev,v) -> VarMp' k v
-assocMetaLevLToVarMp l = varmpUnions [ varmpMetaLevSingleton lev k v | (k,(lev,v)) <- l ]
-
-assocLToVarMp :: Ord k => AssocL k v -> VarMp' k v
-assocLToVarMp = mkVarMp . Map.fromList
-
+%%[6.assocTyLToVarMp -4.assocTyLToVarMp export(assocMetaLevTyLToVarMp,assocTyLToVarMp,varmpToAssocTyL)
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 ]
%%]
@@ -270,14 +175,10 @@ varmpPlus (VarMp l1) (VarMp l2) = VarMp (l1 ++ l2)
(|+>) = varmpPlus
%%]
-%%[6.varmpPlus -2.varmpPlus export(varmpPlus)
-infixr 7 `varmpPlus`
-
-varmpPlus :: Ord k => VarMp' k v -> VarMp' k v -> VarMp' k v
-varmpPlus = (|+>) -- (VarMp l1) (VarMp l2) = VarMp (l1 `Map.union` l2)
+%%[6.varmpPlus -2.varmpPlus
%%]
-%%[4 export(varmpUnion,varmpUnions)
+%%[4.varmpUnion export(varmpUnion,varmpUnions)
varmpUnion :: Ord k => VarMp' k v -> VarMp' k v -> VarMp' k v
varmpUnion = varmpPlus
@@ -287,51 +188,7 @@ varmpUnions [x] = x
varmpUnions l = foldr1 varmpPlus l
%%]
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-%%% Fold: map
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-%%[8 export(varmpMapMaybe,varmpMap)
-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}
-%%]
-
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-%%% Lookup as VarLookup
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-%%[6 export(varmpUnionWith)
--- | 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
-%%]
-
-%%[8 export(varmpInsertWith)
-varmpInsertWith :: Ord k => (v -> v -> v) -> k -> v -> VarMp' k v -> VarMp' k v
-varmpInsertWith f k v = varmpUnionWith f (varmpSingleton k v)
-%%]
-
-%%[6
-instance Ord k => VarLookup (VarMp' k v) 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
-
-
-instance Ord k => VarLookupCmb (VarMp' k v) (VarMp' k v) where
- m1 |+> m2 = varmpUnionWith const m1 m2
+%%[6.varmpUnion -4.varmpUnion
%%]
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@@ -408,17 +265,14 @@ type VarMp = VarMp' TyVarId Ty
%%[6 -2.VarMp.Base
type VarMp = VarMp' TyVarId VarMpInfo
-
-instance Show (VarMp' k v) where
- show _ = "VarMp"
%%]
-%%[4.varmpFilterTy
+%%[4.varmpFilterTy export(varmpFilterTy)
varmpFilterTy :: (k -> v -> Bool) -> VarMp' k v -> VarMp' k v
varmpFilterTy = varmpFilter
%%]
-%%[6.varmpFilterTy -4.varmpFilterTy
+%%[6.varmpFilterTy -4.varmpFilterTy export(varmpFilterTy)
varmpFilterTy :: Ord k => (k -> Ty -> Bool) -> VarMp' k VarMpInfo -> VarMp' k VarMpInfo
varmpFilterTy f
= varmpFilter
@@ -582,10 +436,7 @@ varmpTyLookup tv (VarMp s) = lookup tv s
varmpLookup = varmpTyLookup
%%]
-%%[6 -2.varmpTyLookup export(varmpLookup,varmpTyLookup)
-varmpLookup :: (VarLookup m k i,Ord k) => k -> m -> Maybe i
-varmpLookup = varlookupMap (Just . id)
-
+%%[6 -2.varmpTyLookup export(varmpTyLookup)
varmpTyLookup :: (VarLookup m k VarMpInfo,Ord k) => k -> m -> Maybe Ty
varmpTyLookup = varlookupMap vmiMbTy
%%]
@@ -684,74 +535,18 @@ varmpLabelLookup2 m v = varmpLabelLookup v m
%%]
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-%%% VarMp stack, for nested/local behavior
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
-%%[8 export(VarMpStk')
-newtype VarMpStk' k v
- = VarMpStk [VarMp' k v]
- deriving (Show)
-%%]
-
-%%[8 export(emptyVarMpStk, varmpstkUnit)
-emptyVarMpStk :: VarMpStk' k v
-emptyVarMpStk = VarMpStk [emptyVarMp]
-
-varmpstkUnit :: Ord k => k -> v -> VarMpStk' k v
-varmpstkUnit k v = VarMpStk [mkVarMp (Map.fromList [(k,v)])]
-%%]
-
-%%[8 export(varmpstkPushEmpty, varmpstkPop)
-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"
-%%]
-
-%%[8 export(varmpstkToAssocL, varmpstkKeysSet)
-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
-%%]
-
-%%[8 export(varmpstkUnions)
-varmpstkUnions :: Ord k => [VarMpStk' k v] -> VarMpStk' k v
-varmpstkUnions [x] = x
-varmpstkUnions l = foldr (|+>) emptyVarMpStk l
-%%]
-
-%%[8
-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
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%[2.ppVarMp
ppVarMp :: (PP k, PP v) => ([PP_Doc] -> PP_Doc) -> VarMp' k v -> PP_Doc
ppVarMp ppL (VarMp l) = ppL . map (\(n,v) -> pp n >|< ":->" >|< pp v) $ l
-%%]
-%%[2
ppVarMpV :: VarMp -> PP_Doc
ppVarMpV = ppVarMp vlist
%%]
-%%[6.ppVarMp -2.ppVarMp export(ppVarMp)
-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
- ]
+%%[6.ppVarMp -2.ppVarMp
%%]
%%[2.PP
@@ -759,9 +554,7 @@ instance (PP k, PP v) => PP (VarMp' k v) where
pp = ppVarMp (ppListSepFill "" "" ", ")
%%]
-%%[8
-instance (PP k, PP v) => PP (VarMpStk' k v) where
- pp (VarMpStk s) = ppListSepFill "" "" "; " $ map pp s
+%%[6.PP -2.PP
%%]
%%[99.ppVarMpInfoCfgTy export(ppVarMpInfoCfgTy,ppVarMpInfoDt)
Please sign in to comment.
Something went wrong with that request. Please try again.