A type for tracking well-typed edits to a codebase, equipped with a commutative merge function

Edit.hs

module Edit where

import qualified Data.Map as Map
import Data.Map (Map)
import qualified Data.Set as Set
import Data.Set (Set)
import Data.List
import Data.Maybe

-- | Invariant: if a hash is open, its dependents in the `Edit` must also be open
data Edit h =
  Edit { closed :: Map h (Set h)
       , opened :: Map (h,h) (Set h) }

instance Ord h => Monoid (Edit h) where
  mempty = Edit Map.empty Map.empty
  mappend (Edit c1 o1) (Edit c2 o2) = Edit c o
    where
    keep c (h,h2) = maybe True (Set.notMember h2) (Map.lookup h c)
    c = Map.unionWith Set.union c1 c2
    o = Map.unionWith Set.union o1' o2'
    -- subtract from `o2` any entries closed by `c1`
    -- and subtract from `o1` any entries closed by `c2`
    o2' = Map.filterWithKey (\e _ -> keep c1 e) o2
    o1' = Map.filterWithKey (\e _ -> keep c2 e) o1

scope :: Edit h -> Set h
scope = Map.keysSet . closed

resolve :: Ord h => (Set h -> h) -> h -> Edit h -> Edit h
resolve r h (Edit closed opened) =
  Edit (Map.adjust (Set.singleton . r) h closed) opened

class Ord h => Dependencies h where
  dependencies :: h -> Set h
  dependents :: h -> Set h

transitiveDependencies :: Dependencies h => (h -> Bool) -> h -> Set h
transitiveDependencies guard h | guard h =
  let dh = dependencies h
  in dh `Set.union` (Set.unions $ map (transitiveDependencies guard) (Set.toList dh))
transitiveDependencies _ _ = Set.empty

transitiveDependents :: Dependencies h => (h -> Bool) -> h -> Set h
transitiveDependents guard h | guard h =
  let dh = dependents h
  in dh `Set.union` (Set.unions $ map (transitiveDependents guard) (Set.toList dh))
transitiveDependents _ _ = Set.empty

transitiveDependents' :: Dependencies h => h -> Set h
transitiveDependents' = transitiveDependents (const True)

-- Like `resolve`, but propagates the resolution out to transitive dependents
resolve' :: Dependencies h => (Set h -> h) -> h -> Edit h -> Edit h
resolve' r h (Edit closed opened) =
  let
    closed' = Map.adjust (Set.singleton . r) h closed
    kept = maybe Set.empty keep' (Map.lookup h closed)
    keep' hs = Set.unions . map transitiveDependents' $ Set.toList hs
    dirty = transitiveDependents (\h -> Map.member h closed') h
    prune h s =
      if Set.member h dirty then Set.filter (\h -> Set.member h kept) s
      else s
  -- for all dependents of initial change, strip out any hashes
  -- that don't depend on `kept`, the resolved hash
  in Edit (Map.mapWithKey prune closed') opened

-- | Open a hash for editing. Preserves the `Edit` invariants.
-- Thus opening a hash results in all transitive dependents referenced
-- by the `Edit` being opened as well.
open :: Dependencies h => (h -> (h, Set h)) -> h -> Edit h -> Edit h
open breakDeps h e@(Edit closed opened) =
  -- am like 73% sure this is correct
  let
    (h', deps) = breakDeps h
    hs' = Set.insert h' $ fromMaybe Set.empty (Map.lookup h closed)
    closed' = Map.delete h closed -- a hash cannot be closed and open
    addDeps s = Just $ Set.union (fromMaybe Set.empty s) deps
    -- when opening, preserve existing info
    opened' = foldl (\m h' -> Map.alter addDeps (h,h') m) opened (Set.toList hs')
    -- there may be some dependents of 'h' that need to be opened to preserve invariant
    e' = Edit closed' opened'
    dirty = Map.keys (submap (dependents h) closed')
  in foldl' (\e h -> open breakDeps h e) e' dirty

-- | The submap of the input containing only keys that exist in the given
-- `Set`. Trims the map first with some `log(n)` splits, then filters remaining
-- keys in linear time. This really belongs in Data.Map.
submap :: Ord k => Set k -> Map k v -> Map k v
submap ks _ | Set.null ks = Map.empty
submap ks m =
  let
    (low,high) = (Set.findMin ks, Set.findMax ks)
    lowEdge = maybe Map.empty (Map.singleton low) (Map.lookup low m)
    highEdge = maybe Map.empty (Map.singleton high) (Map.lookup high m)
    (middle, _) = Map.split low m
    (trimmedMiddle, _) = Map.split high middle
    filteredMiddle = Map.filterWithKey (\k _ -> Set.member k ks) trimmedMiddle
  in
    lowEdge `Map.union` filteredMiddle `Map.union` highEdge