module Fixer.VMap(
VMap(),
Proxy(..),
vmapSingleton,
vmapArgSingleton,
vmapArg,
vmapValue,
vmapMember,
vmapProxyIndirect,
vmapPlaceholder,
vmapDropArgs,
vmapHeads
)where
import Data.Monoid(Monoid(..))
import Data.Typeable
import Data.List(intersperse)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Doc.DocLike
import Fixer.Fixer
import GenUtil
data VMap p n = VMap {
vmapArgs :: Map.Map (n,Int) (VMap p n),
vmapNodes :: Either (Proxy p) (Set.Set n)
}
deriving(Typeable)
data Proxy p = Proxy p | DepthExceeded
deriving(Eq,Ord,Typeable)
instance Show p => Show (Proxy p) where
showsPrec n (Proxy p) = showsPrec n p
showsPrec n DepthExceeded = ('*':)
emptyVMap :: (Ord p, Ord n) => VMap p n
emptyVMap = VMap { vmapArgs = mempty, vmapNodes = Right mempty }
vmapSingleton :: (Ord p, Ord n) => n -> VMap p n
vmapSingleton n = emptyVMap { vmapNodes = Right $ Set.singleton n }
vmapArgSingleton :: (Ord p,Ord n,Show p,Show n) => n -> Int -> VMap p n -> VMap p n
vmapArgSingleton n i v
| isBottom v = emptyVMap
| otherwise = pruneVMap $ emptyVMap { vmapArgs = Map.singleton (n,i) v }
vmapArg :: (Ord p,Ord n,Show p,Show n) => n -> Int -> VMap p n -> VMap p n
vmapArg n i vm@VMap { vmapArgs = map } = case Map.lookup (n,i) map of
Just x -> x `lub` vmapProxyIndirect i vm
Nothing -> vmapProxyIndirect i vm
vmapProxyIndirect :: (Show p,Show n,Ord p,Ord n,Fixable (VMap p n)) => Int -> VMap p n -> VMap p n
vmapProxyIndirect _ VMap { vmapNodes = Left l } = emptyVMap { vmapNodes = Left l }
vmapProxyIndirect _ _ = emptyVMap
vmapValue :: (Show p,Show n,Ord p,Ord n) => n -> [VMap p n] -> VMap p n
vmapValue n xs = pruneVMap VMap { vmapArgs = Map.fromAscList (zip (zip (repeat n) [0..]) xs), vmapNodes = Right $ Set.singleton n }
vmapPlaceholder :: (Show p,Show n,Ord p,Ord n) => p -> VMap p n
vmapPlaceholder p = emptyVMap { vmapNodes = Left (Proxy p) }
vmapDropArgs :: Ord n => VMap p n -> VMap p n
vmapDropArgs vm = vm { vmapArgs = mempty }
vmapHeads :: Monad m => VMap p n -> m [n]
vmapHeads VMap { vmapNodes = Left _ } = fail "vmapHeads: VMap is unknown"
vmapHeads VMap { vmapNodes = Right set } = return $ Set.toList set
vmapMember :: Ord n => n -> VMap p n -> Bool
vmapMember n VMap { vmapNodes = Left _ } = True
vmapMember n VMap { vmapNodes = Right set } = n `Set.member` set
pruneVMap :: (Ord n,Ord p,Show n,Show p) => VMap p n -> VMap p n
pruneVMap vmap = f (7::Int) vmap where
f 0 _ = emptyVMap { vmapNodes = Left DepthExceeded }
f _ VMap { vmapNodes = Left p} = emptyVMap {vmapNodes = Left p}
f n VMap { vmapArgs = map, vmapNodes = set} = VMap {vmapArgs = map', vmapNodes = set} where
map' = Map.filter g (Map.map (f (n 1)) map)
g vs = not $ isBottom vs
instance (Ord p,Ord n,Show p,Show n) => Show (VMap p n) where
showsPrec n VMap { vmapNodes = Left p } = showsPrec n p
showsPrec _ VMap { vmapArgs = n, vmapNodes = Right s } = braces (hcat (intersperse (char ',') $ (map f $ snub $ (fsts $ Map.keys n) ++ Set.toList s) )) where
f a = (if a `Set.member` s then tshow a else char '#' <> tshow a) <> (if null (g a) then empty else tshow (g a))
g a = sortUnder fst [ (i,v) | ((a',i),v) <- Map.toList n, a' == a ]
instance (Show p,Show n,Ord p,Ord n) => Fixable (VMap p n) where
bottom = emptyVMap
isBottom VMap { vmapArgs = m, vmapNodes = Right s } = Map.null m && Set.null s
isBottom _ = False
lub x y | x `lte` y = y
lub x y | y `lte` x = x
lub VMap { vmapNodes = Left p } _ = emptyVMap { vmapNodes = Left p }
lub _ VMap { vmapNodes = Left p } = emptyVMap { vmapNodes = Left p }
lub VMap { vmapArgs = as, vmapNodes = Right ns } VMap { vmapArgs = as', vmapNodes = Right ns'} = pruneVMap $ VMap {vmapArgs = Map.unionWith lub as as', vmapNodes = Right $ Set.union ns ns' }
minus _ VMap { vmapNodes = Left _ } = bottom
minus x@VMap { vmapNodes = Left _ } _ = x
minus VMap { vmapArgs = n1, vmapNodes = Right w1} VMap { vmapArgs = n2, vmapNodes = Right w2 } = pruneVMap $ VMap { vmapArgs = Map.fromAscList $ [
case Map.lookup (a,i) n2 of
Just v' -> ((a,i),v `minus` v')
Nothing -> ((a,i),v)
| ((a,i),v) <- Map.toAscList n1 ], vmapNodes = Right (w1 Set.\\ w2) }
lte _ VMap { vmapNodes = Left _ } = True
lte VMap { vmapNodes = Left _ } _ = False
lte x@VMap { vmapArgs = as, vmapNodes = Right ns } y@VMap { vmapArgs = as', vmapNodes = Right ns'} = (Set.null (ns Set.\\ ns') && (Map.null $ Map.differenceWith (\a b -> if a `lte` b then Nothing else Just undefined) as as'))
showFixable x = show x
instance (Show p,Show n,Ord p,Ord n) => Monoid (VMap p n) where
mempty = bottom
mappend = lub