module MO.Util (
module MO.Util,
module MO.Capture,
module StringTable.Atom,
trace
) where
import Data.Set (Set)
import qualified Data.Set as Set
import MO.Capture
import Data.Map (Map)
import StringTable.AtomMap as AtomMap hiding (map)
import Control.Monad (when)
import Debug.Trace (trace)
import Data.Typeable hiding (cast)
import GHC.Exts (unsafeCoerce#, Word(W#), Word#)
import StringTable.Atom
import qualified Data.Typeable as Typeable
infixl 0 `on`
on :: (b -> b -> c) -> (a -> b) -> a -> a -> c
(*) `on` f = \x y -> f x * f y
traceShow :: Show a => a -> b -> b
traceShow = trace . show
traceM :: Monad m => String -> m ()
traceM x = trace x (return ())
(?==?) :: (Eq a, Typeable a, Typeable b) => a -> b -> Bool
(?==?) x y = case Typeable.cast y of
Just y' -> x == y'
_ -> False
(?<=>?) :: (Ord a, Typeable a, Typeable b) => a -> b -> Ordering
(?<=>?) x y = case Typeable.cast y of
Just y' -> x `compare` y'
_ -> show (typeOf x) `compare` show (typeOf y)
addressOf :: a -> Word
addressOf x = W# (unsafeCoerce# x)
data Ord a => Collection a
= MkCollection
{ c_objects :: Set a
, c_names :: AtomMap a
}
deriving (Eq, Ord, Typeable)
instance (Ord a, Show a) => Show (Collection a) where
show (MkCollection _ n) = "<" ++ show n ++ ">"
cmap :: (Ord a, Ord b) => (a -> b) -> Collection a -> Collection b
cmap f MkCollection { c_names = bn } =
let l = map (\(x,y) -> (x, f y)) (AtomMap.toList bn)
in newCollection l
remove :: (Monad m, Ord a) => Atom -> a -> Collection a -> m (Collection a)
remove name obj MkCollection{ c_objects = bo, c_names = bn } = do
return $ MkCollection { c_objects = Set.delete obj bo
, c_names = AtomMap.delete name bn
}
add :: (Monad m, Ord a) => Atom -> a -> Collection a -> m (Collection a)
add name obj c@MkCollection{ c_objects = bo, c_names = bn } = do
when (includes_name c name) $ fail "can't insert: name confict"
return $ MkCollection { c_objects = Set.insert obj bo
, c_names = AtomMap.insert name obj bn
}
insert :: (Ord a) => Atom -> a -> Collection a -> Collection a
insert name obj MkCollection{ c_objects = bo, c_names = bn } =
MkCollection { c_objects = Set.insert obj bo
, c_names = AtomMap.insert name obj bn
}
emptyCollection :: Ord a => Collection a
emptyCollection = newCollection []
newCollection :: Ord a => [(Atom, a)] -> Collection a
newCollection l = MkCollection { c_objects = os, c_names = ns }
where os = Set.fromList (map snd l)
ns = AtomMap.fromList l
newCollection' :: Ord a => (a -> Atom) -> [a] -> Collection a
newCollection' f l = newCollection pairs
where pairs = map (\x -> (f x, x)) l
newCollectionMap :: Ord a => AtomMap a -> Collection a
newCollectionMap ns = MkCollection { c_objects = os, c_names = ns }
where os = Set.fromList (AtomMap.elems ns)
items :: Ord a => Collection a -> [a]
items c = Set.elems (c_objects c)
items_named :: Ord a => Collection a -> [(Atom, a)]
items_named = AtomMap.toList . c_names
includes :: Ord a => Collection a -> a -> Bool
includes c obj = Set.member obj (c_objects c)
includes_name :: Ord a => Collection a -> Atom -> Bool
includes_name c name = AtomMap.member name (c_names c)
includes_any :: Ord a => Collection a -> [a] -> Bool
includes_any _ [] = False
includes_any c (x:xs) = (includes c x) || (includes_any c xs)
includes_any_name :: Ord a => Collection a -> [Atom] -> Bool
includes_any_name _ [] = False
includes_any_name c (x:xs) = (includes_name c x) || (includes_any_name c xs)
includes_all :: Ord a => Collection a -> [a] -> Bool
includes_all _ [] = False
includes_all c (x:xs) = (includes c x) && (includes_any c xs)
shadow :: Ord a => [Collection a] -> [a]
shadow = AtomMap.elems . shadow'
shadow' :: Ord a => [Collection a] -> AtomMap a
shadow' = AtomMap.unions . map c_names
shadow_collection :: Ord a => [Collection a] -> Collection a
shadow_collection = newCollectionMap . shadow'
merge :: Ord a => [Collection a] -> [a]
merge = AtomMap.elems . merge'
merge' :: Ord a => [Collection a] -> AtomMap a
merge' = foldl (AtomMap.unionWithKey (\k _ _ -> error ("merge conflict: " ++ show k))) AtomMap.empty . map c_names
merge_collection :: Ord a => [Collection a] -> Collection a
merge_collection = newCollectionMap . merge'
sym_shadowing :: (Show a, Ord a) => b -> (b -> [b]) -> (b -> Collection a) -> Collection a
sym_shadowing o parents f = shadow_collection [f o, all_parents]
where all_parents = sym_merged_parents o parents f
sym_merged_parents :: (Show a, Ord a) => b -> (b -> [b]) -> (b -> Collection a) -> Collection a
sym_merged_parents o parents f = merge_collection cs
where cs = map (\x -> sym_shadowing x parents f) (parents o)
sym_inheritance :: Ord a => b -> (b -> [b]) -> (b -> (Collection a)) -> Collection a
sym_inheritance o parents f = merge_collection (all_parents ++ [f o])
where all_parents = map (\p -> sym_inheritance p parents f) (parents o)