module Fixer.VMap( VMap(), Proxy(..), vmapSingleton, vmapArgSingleton, vmapArg, vmapValue, vmapMember, vmapProxyIndirect, vmapPlaceholder, vmapDropArgs, vmapHeads )where import Data.Monoid import Data.Typeable import List(intersperse) import qualified Data.Map as Map import qualified Data.Set as Set import Doc.DocLike import Fixer.Fixer import GenUtil -- VMap general data type for finding the fixpoint of a general tree-like structure. 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 a,Ord b) => VMap a b emptyVMap = VMap { vmapArgs = mempty, vmapNodes = Right mempty } vmapSingleton n = emptyVMap { vmapNodes = Right $ Set.singleton n } vmapArgSingleton n i v | isBottom v = emptyVMap | otherwise = pruneVMap $ emptyVMap { vmapArgs = Map.singleton (n,i) v } 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 vm = vm { vmapArgs = mempty } vmapHeads VMap { vmapNodes = Left _ } = fail "vmapHeads: VMap is unknown" vmapHeads VMap { vmapNodes = Right set } = return $ Set.toList set vmapMember n VMap { vmapNodes = Left _ } = True vmapMember n VMap { vmapNodes = Right set } = n `Set.member` set 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