-----------------------------------------------------------------------
-- |
-- Module           : Data.IntervalsMap
-- Description      : Nested intervals
-- Copyright        : (c) Galois, Inc 2020
-- License          : BSD3
-- Maintainer       : Daniel Matichuk <dmatichuk@galois.com>
-- Stability        : provisional
------------------------------------------------------------------------

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FunctionalDependencies #-}

module Data.Parameterized.IntervalsMap
  ( IntervalF(..)
  , mkIntervalF
  , Intervals(..)
  , IntervalsMap
  , intersecting
  , unionWith
  , unionWithM
  , singleton
  , insertWith
  , insertWithM
  , intersectionWith
  , mapMIntersecting
  , fromList
  , toList
  , empty
  , IM.Interval(..)
  , mergeIntervalsF
  , mergeWithM
  , AsOrd(..)
  ) where


import           Data.Kind ( Type )
import           Data.Maybe (catMaybes)

import           Data.IntervalMap.Strict ( IntervalMap )
import qualified Data.IntervalMap.Strict as IM
import qualified Data.IntervalMap.Interval as IM
import qualified Data.IntervalMap.Generic.Strict as IMG

import           Data.Parameterized.Classes
import qualified Data.Parameterized.Context as Ctx

newtype AsOrd f tp where
  AsOrd :: { forall {k} (f :: k -> *) (tp :: k). AsOrd f tp -> f tp
unAsOrd :: f tp } -> AsOrd f tp

instance TestEquality f => Eq (AsOrd f tp) where
  (AsOrd f tp
a) == :: AsOrd f tp -> AsOrd f tp -> Bool
== (AsOrd f tp
b) = case f tp -> f tp -> Maybe (tp :~: tp)
forall (a :: k) (b :: k). f a -> f b -> Maybe (a :~: b)
forall {k} (f :: k -> *) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality f tp
a f tp
b of
    Just tp :~: tp
Refl -> Bool
True
    Maybe (tp :~: tp)
_ -> Bool
False

instance OrdF f => Ord (AsOrd f tp) where
  compare :: AsOrd f tp -> AsOrd f tp -> Ordering
compare (AsOrd f tp
a) (AsOrd f tp
b) = OrderingF tp tp -> Ordering
forall {k} (x :: k) (y :: k). OrderingF x y -> Ordering
toOrdering (OrderingF tp tp -> Ordering) -> OrderingF tp tp -> Ordering
forall a b. (a -> b) -> a -> b
$ f tp -> f tp -> OrderingF tp tp
forall (x :: k) (y :: k). f x -> f y -> OrderingF x y
forall k (ktp :: k -> *) (x :: k) (y :: k).
OrdF ktp =>
ktp x -> ktp y -> OrderingF x y
compareF f tp
a f tp
b

newtype IntervalF f tp where
  IntervalF :: IM.Interval (AsOrd f tp) -> IntervalF f tp

mkIntervalF ::
  IM.Interval (f tp) -> IntervalF f tp
mkIntervalF :: forall {k} (f :: k -> *) (tp :: k).
Interval (f tp) -> IntervalF f tp
mkIntervalF Interval (f tp)
ival = Interval (AsOrd f tp) -> IntervalF f tp
forall {k} (f :: k -> *) (tp :: k).
Interval (AsOrd f tp) -> IntervalF f tp
IntervalF (Interval (AsOrd f tp) -> IntervalF f tp)
-> Interval (AsOrd f tp) -> IntervalF f tp
forall a b. (a -> b) -> a -> b
$ (f tp -> AsOrd f tp) -> Interval (f tp) -> Interval (AsOrd f tp)
forall a b. (a -> b) -> Interval a -> Interval b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f tp -> AsOrd f tp
forall {k} (f :: k -> *) (tp :: k). f tp -> AsOrd f tp
AsOrd Interval (f tp)
ival

instance TestEquality f => TestEquality (IntervalF f) where
  testEquality :: forall (a :: k) (b :: k).
IntervalF f a -> IntervalF f b -> Maybe (a :~: b)
testEquality (IntervalF Interval (AsOrd f a)
i1) (IntervalF Interval (AsOrd f b)
i2) = case f a -> f b -> Maybe (a :~: b)
forall (a :: k) (b :: k). f a -> f b -> Maybe (a :~: b)
forall {k} (f :: k -> *) (a :: k) (b :: k).
TestEquality f =>
f a -> f b -> Maybe (a :~: b)
testEquality (AsOrd f a -> f a
forall {k} (f :: k -> *) (tp :: k). AsOrd f tp -> f tp
unAsOrd (Interval (AsOrd f a) -> AsOrd f a
forall a. Interval a -> a
IM.lowerBound Interval (AsOrd f a)
i1)) (AsOrd f b -> f b
forall {k} (f :: k -> *) (tp :: k). AsOrd f tp -> f tp
unAsOrd (Interval (AsOrd f b) -> AsOrd f b
forall a. Interval a -> a
IM.lowerBound Interval (AsOrd f b)
i2)) of
    Just a :~: b
Refl | Interval (AsOrd f a)
i1 Interval (AsOrd f a) -> Interval (AsOrd f a) -> Bool
forall a. Eq a => a -> a -> Bool
== Interval (AsOrd f a)
Interval (AsOrd f b)
i2 -> (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
    Maybe (a :~: b)
_ -> Maybe (a :~: b)
forall a. Maybe a
Nothing

deriving instance TestEquality f => Eq (IntervalF f tp)

deriving instance OrdF f => Ord (IntervalF f tp)

newtype Intervals f ctx = Intervals (Ctx.Assignment (IntervalF f) ctx)

deriving instance TestEquality f => Eq (Intervals f ctx)

instance OrdF f => Ord (Intervals f ctx) where
  compare :: Intervals f ctx -> Intervals f ctx -> Ordering
compare (Intervals (Assignment (IntervalF f) ctx
rest1 Ctx.:> IntervalF f tp
a1)) (Intervals (Assignment (IntervalF f) ctx
rest2 Ctx.:> IntervalF f tp
a2)) =
    IntervalF f tp -> IntervalF f tp -> Ordering
forall a. Ord a => a -> a -> Ordering
compare IntervalF f tp
a1 IntervalF f tp
IntervalF f tp
a2 Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Intervals f ctx -> Intervals f ctx -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Assignment (IntervalF f) ctx -> Intervals f ctx
forall {k} (f :: k -> *) (ctx :: Ctx k).
Assignment (IntervalF f) ctx -> Intervals f ctx
Intervals Assignment (IntervalF f) ctx
rest1) (Assignment (IntervalF f) ctx -> Intervals f ctx
forall {k} (f :: k -> *) (ctx :: Ctx k).
Assignment (IntervalF f) ctx -> Intervals f ctx
Intervals Assignment (IntervalF f) ctx
Assignment (IntervalF f) ctx
rest2)
  compare (Intervals Assignment (IntervalF f) ctx
Ctx.Empty) (Intervals Assignment (IntervalF f) ctx
Ctx.Empty) = Ordering
EQ

data IntervalsMap (f :: k -> Type) (ctx :: Ctx.Ctx k) tp where
  IntervalsMapCons ::
    IntervalMap (AsOrd f idx) (IntervalsMap f ctx tp) ->
    IntervalsMap f (ctx Ctx.::> idx) tp
  IntervalsMapHead :: tp -> IntervalsMap f Ctx.EmptyCtx tp

instance Functor (IntervalsMap f ctx) where
  fmap :: forall a b.
(a -> b) -> IntervalsMap f ctx a -> IntervalsMap f ctx b
fmap a -> b
f IntervalsMap f ctx a
ims = case IntervalsMap f ctx a
ims of
    IntervalsMapCons IntervalMap (AsOrd f idx) (IntervalsMap f ctx a)
ims' -> IntervalMap (AsOrd f idx) (IntervalsMap f ctx b)
-> IntervalsMap f (ctx '::> idx) b
forall {k} (f :: k -> *) (idx :: k) (ctx :: Ctx k) tp.
IntervalMap (AsOrd f idx) (IntervalsMap f ctx tp)
-> IntervalsMap f (ctx ::> idx) tp
IntervalsMapCons ((IntervalsMap f ctx a -> IntervalsMap f ctx b)
-> IntervalMap (AsOrd f idx) (IntervalsMap f ctx a)
-> IntervalMap (AsOrd f idx) (IntervalsMap f ctx b)
forall a b.
(a -> b)
-> IntervalMap (Interval (AsOrd f idx)) a
-> IntervalMap (Interval (AsOrd f idx)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> IntervalsMap f ctx a -> IntervalsMap f ctx b
forall a b.
(a -> b) -> IntervalsMap f ctx a -> IntervalsMap f ctx b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) IntervalMap (AsOrd f idx) (IntervalsMap f ctx a)
ims')
    IntervalsMapHead a
v -> b -> IntervalsMap f 'EmptyCtx b
forall {k} tp (f :: k -> *). tp -> IntervalsMap f EmptyCtx tp
IntervalsMapHead (b -> IntervalsMap f 'EmptyCtx b)
-> b -> IntervalsMap f 'EmptyCtx b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
v

instance Foldable (IntervalsMap f ctx) where
  foldMap :: forall m a. Monoid m => (a -> m) -> IntervalsMap f ctx a -> m
foldMap a -> m
f (IntervalsMapCons IntervalMap (AsOrd f idx) (IntervalsMap f ctx a)
ims') = (IntervalsMap f ctx a -> m)
-> IntervalMap (AsOrd f idx) (IntervalsMap f ctx a) -> m
forall m a.
Monoid m =>
(a -> m) -> IntervalMap (Interval (AsOrd f idx)) a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((a -> m) -> IntervalsMap f ctx a -> m
forall m a. Monoid m => (a -> m) -> IntervalsMap f ctx a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f) IntervalMap (AsOrd f idx) (IntervalsMap f ctx a)
ims'
  foldMap a -> m
f (IntervalsMapHead a
v) = a -> m
f a
v

instance Traversable (IntervalsMap f ctx) where
  traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> IntervalsMap f ctx a -> f (IntervalsMap f ctx b)
traverse a -> f b
f (IntervalsMapCons IntervalMap (AsOrd f idx) (IntervalsMap f ctx a)
ims') = IntervalMap (AsOrd f idx) (IntervalsMap f ctx b)
-> IntervalsMap f ctx b
IntervalMap (AsOrd f idx) (IntervalsMap f ctx b)
-> IntervalsMap f (ctx '::> idx) b
forall {k} (f :: k -> *) (idx :: k) (ctx :: Ctx k) tp.
IntervalMap (AsOrd f idx) (IntervalsMap f ctx tp)
-> IntervalsMap f (ctx ::> idx) tp
IntervalsMapCons (IntervalMap (AsOrd f idx) (IntervalsMap f ctx b)
 -> IntervalsMap f ctx b)
-> f (IntervalMap (AsOrd f idx) (IntervalsMap f ctx b))
-> f (IntervalsMap f ctx b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IntervalsMap f ctx a -> f (IntervalsMap f ctx b))
-> IntervalMap (AsOrd f idx) (IntervalsMap f ctx a)
-> f (IntervalMap (AsOrd f idx) (IntervalsMap f ctx b))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b)
-> IntervalMap (Interval (AsOrd f idx)) a
-> f (IntervalMap (Interval (AsOrd f idx)) b)
traverse ((a -> f b) -> IntervalsMap f ctx a -> f (IntervalsMap f ctx b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> IntervalsMap f ctx a -> f (IntervalsMap f ctx b)
traverse a -> f b
f) IntervalMap (AsOrd f idx) (IntervalsMap f ctx a)
ims'
  traverse a -> f b
f (IntervalsMapHead a
v) = b -> IntervalsMap f ctx b
b -> IntervalsMap f 'EmptyCtx b
forall {k} tp (f :: k -> *). tp -> IntervalsMap f EmptyCtx tp
IntervalsMapHead (b -> IntervalsMap f ctx b) -> f b -> f (IntervalsMap f ctx b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
v

intersecting ::
  OrdF f =>
  IntervalsMap f ctx tp ->
  Intervals f ctx ->
  IntervalsMap f ctx tp
intersecting :: forall {k} (f :: k -> *) (ctx :: Ctx k) tp.
OrdF f =>
IntervalsMap f ctx tp -> Intervals f ctx -> IntervalsMap f ctx tp
intersecting (IntervalsMapCons IntervalMap (AsOrd f idx) (IntervalsMap f ctx tp)
ims) (Intervals (Assignment (IntervalF f) ctx
rest Ctx.:> IntervalF Interval (AsOrd f tp)
k)) =
  let
    top :: IntervalMap (AsOrd f idx) (IntervalsMap f ctx tp)
top = IntervalMap (AsOrd f idx) (IntervalsMap f ctx tp)
-> Interval (AsOrd f idx)
-> IntervalMap (AsOrd f idx) (IntervalsMap f ctx tp)
forall k e v.
Interval k e =>
IntervalMap k v -> k -> IntervalMap k v
IM.intersecting IntervalMap (AsOrd f idx) (IntervalsMap f ctx tp)
ims Interval (AsOrd f idx)
Interval (AsOrd f tp)
k
  in IntervalMap (AsOrd f idx) (IntervalsMap f ctx tp)
-> IntervalsMap f (ctx ::> idx) tp
forall {k} (f :: k -> *) (idx :: k) (ctx :: Ctx k) tp.
IntervalMap (AsOrd f idx) (IntervalsMap f ctx tp)
-> IntervalsMap f (ctx ::> idx) tp
IntervalsMapCons (IntervalMap (AsOrd f idx) (IntervalsMap f ctx tp)
 -> IntervalsMap f (ctx ::> idx) tp)
-> IntervalMap (AsOrd f idx) (IntervalsMap f ctx tp)
-> IntervalsMap f (ctx ::> idx) tp
forall a b. (a -> b) -> a -> b
$ (IntervalsMap f ctx tp -> IntervalsMap f ctx tp)
-> IntervalMap (AsOrd f idx) (IntervalsMap f ctx tp)
-> IntervalMap (AsOrd f idx) (IntervalsMap f ctx tp)
forall a b.
(a -> b)
-> IntervalMap (Interval (AsOrd f idx)) a
-> IntervalMap (Interval (AsOrd f idx)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\IntervalsMap f ctx tp
ims' -> IntervalsMap f ctx tp -> Intervals f ctx -> IntervalsMap f ctx tp
forall {k} (f :: k -> *) (ctx :: Ctx k) tp.
OrdF f =>
IntervalsMap f ctx tp -> Intervals f ctx -> IntervalsMap f ctx tp
intersecting IntervalsMap f ctx tp
ims' (Assignment (IntervalF f) ctx -> Intervals f ctx
forall {k} (f :: k -> *) (ctx :: Ctx k).
Assignment (IntervalF f) ctx -> Intervals f ctx
Intervals Assignment (IntervalF f) ctx
rest)) IntervalMap (AsOrd f idx) (IntervalsMap f ctx tp)
IntervalMap (AsOrd f idx) (IntervalsMap f ctx tp)
top
intersecting IntervalsMap f ctx tp
v (Intervals Assignment (IntervalF f) ctx
Ctx.Empty) = IntervalsMap f ctx tp
v

fromList ::
  OrdF f =>
  [(Intervals f (ctx Ctx.::> a), tp)] ->
  IntervalsMap f (ctx Ctx.::> a) tp
fromList :: forall {k} (f :: k -> *) (ctx :: Ctx k) (a :: k) tp.
OrdF f =>
[(Intervals f (ctx ::> a), tp)] -> IntervalsMap f (ctx ::> a) tp
fromList [(Intervals f (ctx ::> a), tp)]
es = (IntervalsMap f (ctx ::> a) tp
 -> IntervalsMap f (ctx ::> a) tp -> IntervalsMap f (ctx ::> a) tp)
-> IntervalsMap f (ctx ::> a) tp
-> [IntervalsMap f (ctx ::> a) tp]
-> IntervalsMap f (ctx ::> a) tp
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((tp -> tp -> tp)
-> IntervalsMap f (ctx ::> a) tp
-> IntervalsMap f (ctx ::> a) tp
-> IntervalsMap f (ctx ::> a) tp
forall {k} (f :: k -> *) a (ctx :: Ctx k).
OrdF f =>
(a -> a -> a)
-> IntervalsMap f ctx a
-> IntervalsMap f ctx a
-> IntervalsMap f ctx a
unionWith (\tp
l tp
_ -> tp
l)) IntervalsMap f (ctx ::> a) tp
forall {k} (f :: k -> *) (ctx :: Ctx k) (a :: k) tp.
IntervalsMap f (ctx ::> a) tp
empty (((Intervals f (ctx ::> a), tp) -> IntervalsMap f (ctx ::> a) tp)
-> [(Intervals f (ctx ::> a), tp)]
-> [IntervalsMap f (ctx ::> a) tp]
forall a b. (a -> b) -> [a] -> [b]
map ((Intervals f (ctx ::> a) -> tp -> IntervalsMap f (ctx ::> a) tp)
-> (Intervals f (ctx ::> a), tp) -> IntervalsMap f (ctx ::> a) tp
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Intervals f (ctx ::> a) -> tp -> IntervalsMap f (ctx ::> a) tp
forall {k} (f :: k -> *) (ctx :: Ctx k) tp.
Intervals f ctx -> tp -> IntervalsMap f ctx tp
singleton) [(Intervals f (ctx ::> a), tp)]
es)

toList ::
  IntervalsMap f ctx tp ->
  [(Intervals f ctx, tp)]
toList :: forall {k} (f :: k -> *) (ctx :: Ctx k) tp.
IntervalsMap f ctx tp -> [(Intervals f ctx, tp)]
toList (IntervalsMapCons IntervalMap (AsOrd f idx) (IntervalsMap f ctx tp)
ims) =
  [[(Intervals f ctx, tp)]] -> [(Intervals f ctx, tp)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[(Intervals f ctx, tp)]] -> [(Intervals f ctx, tp)])
-> [[(Intervals f ctx, tp)]] -> [(Intervals f ctx, tp)]
forall a b. (a -> b) -> a -> b
$ ((Interval (AsOrd f idx), IntervalsMap f ctx tp)
 -> [(Intervals f ctx, tp)])
-> [(Interval (AsOrd f idx), IntervalsMap f ctx tp)]
-> [[(Intervals f ctx, tp)]]
forall a b. (a -> b) -> [a] -> [b]
map (\(Interval (AsOrd f idx)
k, IntervalsMap f ctx tp
es) -> Interval (AsOrd f idx)
-> [(Intervals f ctx, tp)] -> [(Intervals f (ctx '::> idx), tp)]
forall {k} (f :: k -> *) (a :: k) (ctx :: Ctx k) tp.
Interval (AsOrd f a)
-> [(Intervals f ctx, tp)] -> [(Intervals f (ctx ::> a), tp)]
addTo Interval (AsOrd f idx)
k (IntervalsMap f ctx tp -> [(Intervals f ctx, tp)]
forall {k} (f :: k -> *) (ctx :: Ctx k) tp.
IntervalsMap f ctx tp -> [(Intervals f ctx, tp)]
toList IntervalsMap f ctx tp
es)) ([(Interval (AsOrd f idx), IntervalsMap f ctx tp)]
 -> [[(Intervals f ctx, tp)]])
-> [(Interval (AsOrd f idx), IntervalsMap f ctx tp)]
-> [[(Intervals f ctx, tp)]]
forall a b. (a -> b) -> a -> b
$ (IntervalMap (AsOrd f idx) (IntervalsMap f ctx tp)
-> [(Interval (AsOrd f idx), IntervalsMap f ctx tp)]
forall k v. IntervalMap k v -> [(k, v)]
IM.toList IntervalMap (AsOrd f idx) (IntervalsMap f ctx tp)
ims)
  where
    addTo :: IM.Interval (AsOrd f a) -> [(Intervals f ctx, tp)] -> [(Intervals f (ctx Ctx.::> a), tp)]
    addTo :: forall {k} (f :: k -> *) (a :: k) (ctx :: Ctx k) tp.
Interval (AsOrd f a)
-> [(Intervals f ctx, tp)] -> [(Intervals f (ctx ::> a), tp)]
addTo Interval (AsOrd f a)
ival = ((Intervals f ctx, tp) -> (Intervals f (ctx ::> a), tp))
-> [(Intervals f ctx, tp)] -> [(Intervals f (ctx ::> a), tp)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Intervals Assignment (IntervalF f) ctx
ivalf, tp
a) -> (Assignment (IntervalF f) (ctx ::> a) -> Intervals f (ctx ::> a)
forall {k} (f :: k -> *) (ctx :: Ctx k).
Assignment (IntervalF f) ctx -> Intervals f ctx
Intervals (Assignment (IntervalF f) (ctx ::> a) -> Intervals f (ctx ::> a))
-> Assignment (IntervalF f) (ctx ::> a) -> Intervals f (ctx ::> a)
forall a b. (a -> b) -> a -> b
$ Assignment (IntervalF f) ctx
ivalf Assignment (IntervalF f) ctx
-> IntervalF f a -> Assignment (IntervalF f) (ctx ::> a)
forall {k} (ctx' :: Ctx k) (f :: k -> *) (ctx :: Ctx k) (tp :: k).
(ctx' ~ (ctx ::> tp)) =>
Assignment f ctx -> f tp -> Assignment f ctx'
Ctx.:> Interval (AsOrd f a) -> IntervalF f a
forall {k} (f :: k -> *) (tp :: k).
Interval (AsOrd f tp) -> IntervalF f tp
IntervalF Interval (AsOrd f a)
ival, tp
a))
toList (IntervalsMapHead tp
v) = [(Assignment (IntervalF f) ctx -> Intervals f ctx
forall {k} (f :: k -> *) (ctx :: Ctx k).
Assignment (IntervalF f) ctx -> Intervals f ctx
Intervals Assignment (IntervalF f) ctx
Assignment (IntervalF f) 'EmptyCtx
forall {k} (f :: k -> *). Assignment f EmptyCtx
Ctx.empty, tp
v)]

unionWith ::
  OrdF f =>
  (a -> a -> a) ->
  IntervalsMap f ctx a ->
  IntervalsMap f ctx a ->
  IntervalsMap f ctx a
unionWith :: forall {k} (f :: k -> *) a (ctx :: Ctx k).
OrdF f =>
(a -> a -> a)
-> IntervalsMap f ctx a
-> IntervalsMap f ctx a
-> IntervalsMap f ctx a
unionWith a -> a -> a
f (IntervalsMapCons IntervalMap (AsOrd f idx) (IntervalsMap f ctx a)
ims1) (IntervalsMapCons IntervalMap (AsOrd f idx) (IntervalsMap f ctx a)
ims2) =
  IntervalMap (AsOrd f idx) (IntervalsMap f ctx a)
-> IntervalsMap f (ctx '::> idx) a
forall {k} (f :: k -> *) (idx :: k) (ctx :: Ctx k) tp.
IntervalMap (AsOrd f idx) (IntervalsMap f ctx tp)
-> IntervalsMap f (ctx ::> idx) tp
IntervalsMapCons (IntervalMap (AsOrd f idx) (IntervalsMap f ctx a)
 -> IntervalsMap f (ctx '::> idx) a)
-> IntervalMap (AsOrd f idx) (IntervalsMap f ctx a)
-> IntervalsMap f (ctx '::> idx) a
forall a b. (a -> b) -> a -> b
$ (IntervalsMap f ctx a
 -> IntervalsMap f ctx a -> IntervalsMap f ctx a)
-> IntervalMap (AsOrd f idx) (IntervalsMap f ctx a)
-> IntervalMap (AsOrd f idx) (IntervalsMap f ctx a)
-> IntervalMap (AsOrd f idx) (IntervalsMap f ctx a)
forall k e a.
(Interval k e, Ord k) =>
(a -> a -> a)
-> IntervalMap k a -> IntervalMap k a -> IntervalMap k a
IM.unionWith ((a -> a -> a)
-> IntervalsMap f ctx a
-> IntervalsMap f ctx a
-> IntervalsMap f ctx a
forall {k} (f :: k -> *) a (ctx :: Ctx k).
OrdF f =>
(a -> a -> a)
-> IntervalsMap f ctx a
-> IntervalsMap f ctx a
-> IntervalsMap f ctx a
unionWith a -> a -> a
f) IntervalMap (AsOrd f idx) (IntervalsMap f ctx a)
ims1 IntervalMap (AsOrd f idx) (IntervalsMap f ctx a)
IntervalMap (AsOrd f idx) (IntervalsMap f ctx a)
ims2
unionWith a -> a -> a
f (IntervalsMapHead a
v1) (IntervalsMapHead a
v2) = a -> IntervalsMap f 'EmptyCtx a
forall {k} tp (f :: k -> *). tp -> IntervalsMap f EmptyCtx tp
IntervalsMapHead (a -> IntervalsMap f 'EmptyCtx a)
-> a -> IntervalsMap f 'EmptyCtx a
forall a b. (a -> b) -> a -> b
$ a -> a -> a
f a
v1 a
v2

unionWithM ::
  forall f m a ctx.
  OrdF f =>
  Monad m =>
  (a -> a -> m a) ->
  IntervalsMap f ctx a ->
  IntervalsMap f ctx a ->
  m (IntervalsMap f ctx a)
unionWithM :: forall {k} (f :: k -> *) (m :: * -> *) a (ctx :: Ctx k).
(OrdF f, Monad m) =>
(a -> a -> m a)
-> IntervalsMap f ctx a
-> IntervalsMap f ctx a
-> m (IntervalsMap f ctx a)
unionWithM a -> a -> m a
f IntervalsMap f ctx a
ims1 IntervalsMap f ctx a
ims2 = IntervalsMap f ctx (m a) -> m (IntervalsMap f ctx a)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a.
Applicative f =>
IntervalsMap f ctx (f a) -> f (IntervalsMap f ctx a)
sequenceA (IntervalsMap f ctx (m a) -> m (IntervalsMap f ctx a))
-> IntervalsMap f ctx (m a) -> m (IntervalsMap f ctx a)
forall a b. (a -> b) -> a -> b
$ (m a -> m a -> m a)
-> IntervalsMap f ctx (m a)
-> IntervalsMap f ctx (m a)
-> IntervalsMap f ctx (m a)
forall {k} (f :: k -> *) a (ctx :: Ctx k).
OrdF f =>
(a -> a -> a)
-> IntervalsMap f ctx a
-> IntervalsMap f ctx a
-> IntervalsMap f ctx a
unionWith m a -> m a -> m a
go ((a -> m a) -> IntervalsMap f ctx a -> IntervalsMap f ctx (m a)
forall a b.
(a -> b) -> IntervalsMap f ctx a -> IntervalsMap f ctx b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return IntervalsMap f ctx a
ims1) ((a -> m a) -> IntervalsMap f ctx a -> IntervalsMap f ctx (m a)
forall a b.
(a -> b) -> IntervalsMap f ctx a -> IntervalsMap f ctx b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return IntervalsMap f ctx a
ims2)
  where
    go :: m a -> m a -> m a
    go :: m a -> m a -> m a
go m a
f1 m a
f2 = do
      a
v1 <- m a
f1
      a
v2 <- m a
f2
      a -> a -> m a
f a
v1 a
v2

data MergeResult a b =
    MergeLeft a
  | MergeRight b
  | MergeCombined a b

mergeWithM ::
  forall f m a b c ctx.
  OrdF f =>
  Monad m =>
  (a -> m c) ->
  (b -> m c) ->
  (a -> b -> m c) ->
  IntervalsMap f ctx a ->
  IntervalsMap f ctx b ->
  m (IntervalsMap f ctx c)
mergeWithM :: forall {k} (f :: k -> *) (m :: * -> *) a b c (ctx :: Ctx k).
(OrdF f, Monad m) =>
(a -> m c)
-> (b -> m c)
-> (a -> b -> m c)
-> IntervalsMap f ctx a
-> IntervalsMap f ctx b
-> m (IntervalsMap f ctx c)
mergeWithM a -> m c
inLeft b -> m c
inRight a -> b -> m c
combine IntervalsMap f ctx a
ims1 IntervalsMap f ctx b
ims2 = do
  (MergeResult a b -> m c)
-> IntervalsMap f ctx (MergeResult a b) -> m (IntervalsMap f ctx c)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> IntervalsMap f ctx a -> f (IntervalsMap f ctx b)
traverse MergeResult a b -> m c
eval (IntervalsMap f ctx (MergeResult a b) -> m (IntervalsMap f ctx c))
-> IntervalsMap f ctx (MergeResult a b) -> m (IntervalsMap f ctx c)
forall a b. (a -> b) -> a -> b
$ (MergeResult a b -> MergeResult a b -> MergeResult a b)
-> IntervalsMap f ctx (MergeResult a b)
-> IntervalsMap f ctx (MergeResult a b)
-> IntervalsMap f ctx (MergeResult a b)
forall {k} (f :: k -> *) a (ctx :: Ctx k).
OrdF f =>
(a -> a -> a)
-> IntervalsMap f ctx a
-> IntervalsMap f ctx a
-> IntervalsMap f ctx a
unionWith MergeResult a b -> MergeResult a b -> MergeResult a b
go ((a -> MergeResult a b)
-> IntervalsMap f ctx a -> IntervalsMap f ctx (MergeResult a b)
forall a b.
(a -> b) -> IntervalsMap f ctx a -> IntervalsMap f ctx b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> MergeResult a b
forall a b. a -> MergeResult a b
MergeLeft IntervalsMap f ctx a
ims1) ((b -> MergeResult a b)
-> IntervalsMap f ctx b -> IntervalsMap f ctx (MergeResult a b)
forall a b.
(a -> b) -> IntervalsMap f ctx a -> IntervalsMap f ctx b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> MergeResult a b
forall a b. b -> MergeResult a b
MergeRight IntervalsMap f ctx b
ims2)
  where
    eval :: MergeResult a b -> m c
    eval :: MergeResult a b -> m c
eval (MergeLeft a
a) = a -> m c
inLeft a
a
    eval (MergeRight b
b) = b -> m c
inRight b
b
    eval (MergeCombined a
a b
b) = a -> b -> m c
combine a
a b
b

    go :: MergeResult a b -> MergeResult a b -> MergeResult a b
    go :: MergeResult a b -> MergeResult a b -> MergeResult a b
go (MergeLeft a
f1) (MergeRight b
f2) = a -> b -> MergeResult a b
forall a b. a -> b -> MergeResult a b
MergeCombined a
f1 b
f2
    go MergeResult a b
_ MergeResult a b
_ = [Char] -> MergeResult a b
forall a. HasCallStack => [Char] -> a
error [Char]
"mergeWithM: unexpected MergeResult"


singleton ::
  Intervals f ctx ->
  tp ->
  IntervalsMap f ctx tp
singleton :: forall {k} (f :: k -> *) (ctx :: Ctx k) tp.
Intervals f ctx -> tp -> IntervalsMap f ctx tp
singleton (Intervals (Assignment (IntervalF f) ctx
rest Ctx.:> IntervalF Interval (AsOrd f tp)
k)) tp
v = IntervalMap (AsOrd f tp) (IntervalsMap f ctx tp)
-> IntervalsMap f (ctx ::> tp) tp
forall {k} (f :: k -> *) (idx :: k) (ctx :: Ctx k) tp.
IntervalMap (AsOrd f idx) (IntervalsMap f ctx tp)
-> IntervalsMap f (ctx ::> idx) tp
IntervalsMapCons (IntervalMap (AsOrd f tp) (IntervalsMap f ctx tp)
 -> IntervalsMap f (ctx ::> tp) tp)
-> IntervalMap (AsOrd f tp) (IntervalsMap f ctx tp)
-> IntervalsMap f (ctx ::> tp) tp
forall a b. (a -> b) -> a -> b
$ Interval (AsOrd f tp)
-> IntervalsMap f ctx tp
-> IntervalMap (AsOrd f tp) (IntervalsMap f ctx tp)
forall k v. k -> v -> IntervalMap k v
IM.singleton Interval (AsOrd f tp)
k (Intervals f ctx -> tp -> IntervalsMap f ctx tp
forall {k} (f :: k -> *) (ctx :: Ctx k) tp.
Intervals f ctx -> tp -> IntervalsMap f ctx tp
singleton (Assignment (IntervalF f) ctx -> Intervals f ctx
forall {k} (f :: k -> *) (ctx :: Ctx k).
Assignment (IntervalF f) ctx -> Intervals f ctx
Intervals Assignment (IntervalF f) ctx
rest) tp
v)
singleton (Intervals Assignment (IntervalF f) ctx
Ctx.Empty) tp
v = tp -> IntervalsMap f EmptyCtx tp
forall {k} tp (f :: k -> *). tp -> IntervalsMap f EmptyCtx tp
IntervalsMapHead tp
v

empty :: IntervalsMap f (ctx Ctx.::> a) tp
empty :: forall {k} (f :: k -> *) (ctx :: Ctx k) (a :: k) tp.
IntervalsMap f (ctx ::> a) tp
empty = IntervalMap (AsOrd f a) (IntervalsMap f ctx tp)
-> IntervalsMap f (ctx ::> a) tp
forall {k} (f :: k -> *) (idx :: k) (ctx :: Ctx k) tp.
IntervalMap (AsOrd f idx) (IntervalsMap f ctx tp)
-> IntervalsMap f (ctx ::> idx) tp
IntervalsMapCons IntervalMap (AsOrd f a) (IntervalsMap f ctx tp)
forall k v. IntervalMap k v
IM.empty

insertWith ::
  OrdF f =>
  (tp -> tp -> tp) ->
  Intervals f ctx ->
  tp ->
  IntervalsMap f ctx tp ->
  IntervalsMap f ctx tp
insertWith :: forall {k} (f :: k -> *) tp (ctx :: Ctx k).
OrdF f =>
(tp -> tp -> tp)
-> Intervals f ctx
-> tp
-> IntervalsMap f ctx tp
-> IntervalsMap f ctx tp
insertWith tp -> tp -> tp
f Intervals f ctx
k tp
v = (tp -> tp -> tp)
-> IntervalsMap f ctx tp
-> IntervalsMap f ctx tp
-> IntervalsMap f ctx tp
forall {k} (f :: k -> *) a (ctx :: Ctx k).
OrdF f =>
(a -> a -> a)
-> IntervalsMap f ctx a
-> IntervalsMap f ctx a
-> IntervalsMap f ctx a
unionWith tp -> tp -> tp
f (Intervals f ctx -> tp -> IntervalsMap f ctx tp
forall {k} (f :: k -> *) (ctx :: Ctx k) tp.
Intervals f ctx -> tp -> IntervalsMap f ctx tp
singleton Intervals f ctx
k tp
v)


insertWithM ::
  forall m f ctx tp.
  Monad m =>
  OrdF f =>
  (tp -> tp -> m tp) ->
  Intervals f ctx ->
  tp ->
  IntervalsMap f ctx tp ->
  m (IntervalsMap f ctx tp)
insertWithM :: forall {k} (m :: * -> *) (f :: k -> *) (ctx :: Ctx k) tp.
(Monad m, OrdF f) =>
(tp -> tp -> m tp)
-> Intervals f ctx
-> tp
-> IntervalsMap f ctx tp
-> m (IntervalsMap f ctx tp)
insertWithM tp -> tp -> m tp
f Intervals f ctx
k tp
v IntervalsMap f ctx tp
ims = IntervalsMap f ctx (m tp) -> m (IntervalsMap f ctx tp)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a.
Applicative f =>
IntervalsMap f ctx (f a) -> f (IntervalsMap f ctx a)
sequenceA (IntervalsMap f ctx (m tp) -> m (IntervalsMap f ctx tp))
-> IntervalsMap f ctx (m tp) -> m (IntervalsMap f ctx tp)
forall a b. (a -> b) -> a -> b
$ (m tp -> m tp -> m tp)
-> Intervals f ctx
-> m tp
-> IntervalsMap f ctx (m tp)
-> IntervalsMap f ctx (m tp)
forall {k} (f :: k -> *) tp (ctx :: Ctx k).
OrdF f =>
(tp -> tp -> tp)
-> Intervals f ctx
-> tp
-> IntervalsMap f ctx tp
-> IntervalsMap f ctx tp
insertWith m tp -> m tp -> m tp
go Intervals f ctx
k (tp -> m tp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return tp
v) ((tp -> m tp) -> IntervalsMap f ctx tp -> IntervalsMap f ctx (m tp)
forall a b.
(a -> b) -> IntervalsMap f ctx a -> IntervalsMap f ctx b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap tp -> m tp
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return IntervalsMap f ctx tp
ims)
  where
    go :: m tp -> m tp -> m tp
    go :: m tp -> m tp -> m tp
go m tp
f1 m tp
f2 = do
      tp
v1 <- m tp
f1
      tp
v2 <- m tp
f2
      tp -> tp -> m tp
f tp
v1 tp
v2

intersectionWith ::
  OrdF f =>
  (a -> b -> c) ->
  IntervalsMap f ctx a ->
  IntervalsMap f ctx b ->
  IntervalsMap f ctx c
intersectionWith :: forall {k} (f :: k -> *) a b c (ctx :: Ctx k).
OrdF f =>
(a -> b -> c)
-> IntervalsMap f ctx a
-> IntervalsMap f ctx b
-> IntervalsMap f ctx c
intersectionWith a -> b -> c
f (IntervalsMapCons IntervalMap (AsOrd f idx) (IntervalsMap f ctx a)
ims1) (IntervalsMapCons IntervalMap (AsOrd f idx) (IntervalsMap f ctx b)
ims2) =
  IntervalMap (AsOrd f idx) (IntervalsMap f ctx c)
-> IntervalsMap f (ctx '::> idx) c
forall {k} (f :: k -> *) (idx :: k) (ctx :: Ctx k) tp.
IntervalMap (AsOrd f idx) (IntervalsMap f ctx tp)
-> IntervalsMap f (ctx ::> idx) tp
IntervalsMapCons (IntervalMap (AsOrd f idx) (IntervalsMap f ctx c)
 -> IntervalsMap f (ctx '::> idx) c)
-> IntervalMap (AsOrd f idx) (IntervalsMap f ctx c)
-> IntervalsMap f (ctx '::> idx) c
forall a b. (a -> b) -> a -> b
$ (IntervalsMap f ctx a
 -> IntervalsMap f ctx b -> IntervalsMap f ctx c)
-> IntervalMap (AsOrd f idx) (IntervalsMap f ctx a)
-> IntervalMap (Interval (AsOrd f idx)) (IntervalsMap f ctx b)
-> IntervalMap (AsOrd f idx) (IntervalsMap f ctx c)
forall k e a b c.
(Interval k e, Ord k) =>
(a -> b -> c)
-> IntervalMap k a -> IntervalMap k b -> IntervalMap k c
IM.intersectionWith ((a -> b -> c)
-> IntervalsMap f ctx a
-> IntervalsMap f ctx b
-> IntervalsMap f ctx c
forall {k} (f :: k -> *) a b c (ctx :: Ctx k).
OrdF f =>
(a -> b -> c)
-> IntervalsMap f ctx a
-> IntervalsMap f ctx b
-> IntervalsMap f ctx c
intersectionWith a -> b -> c
f) IntervalMap (AsOrd f idx) (IntervalsMap f ctx a)
ims1 IntervalMap (Interval (AsOrd f idx)) (IntervalsMap f ctx b)
IntervalMap (AsOrd f idx) (IntervalsMap f ctx b)
ims2
intersectionWith a -> b -> c
f (IntervalsMapHead a
v1) (IntervalsMapHead b
v2) = c -> IntervalsMap f 'EmptyCtx c
forall {k} tp (f :: k -> *). tp -> IntervalsMap f EmptyCtx tp
IntervalsMapHead (c -> IntervalsMap f 'EmptyCtx c)
-> c -> IntervalsMap f 'EmptyCtx c
forall a b. (a -> b) -> a -> b
$ a -> b -> c
f a
v1 b
v2

mapMIntersecting' ::
  Monad m =>
  OrdF f =>
  Intervals f ctx ->
  (tp -> m (Maybe tp)) ->
  IntervalsMap f ctx tp ->
  m (Maybe (IntervalsMap f ctx tp))
mapMIntersecting' :: forall {k} (m :: * -> *) (f :: k -> *) (ctx :: Ctx k) tp.
(Monad m, OrdF f) =>
Intervals f ctx
-> (tp -> m (Maybe tp))
-> IntervalsMap f ctx tp
-> m (Maybe (IntervalsMap f ctx tp))
mapMIntersecting' (Intervals (Assignment (IntervalF f) ctx
rest Ctx.:> IntervalF Interval (AsOrd f tp)
k)) tp -> m (Maybe tp)
f (IntervalsMapCons IntervalMap (AsOrd f idx) (IntervalsMap f ctx tp)
ims) = do
  IntervalMap (Interval (AsOrd f tp)) (IntervalsMap f ctx tp)
ims' <- Interval (AsOrd f tp)
-> (Interval (AsOrd f tp)
    -> IntervalsMap f ctx tp -> m (Maybe (IntervalsMap f ctx tp)))
-> IntervalMap (Interval (AsOrd f tp)) (IntervalsMap f ctx tp)
-> m (IntervalMap (Interval (AsOrd f tp)) (IntervalsMap f ctx tp))
forall k v e (m :: * -> *).
(Monad m, Interval k e, Ord k) =>
k
-> (k -> v -> m (Maybe v))
-> IntervalMap k v
-> m (IntervalMap k v)
mapMIntersectingBase Interval (AsOrd f tp)
k (\Interval (AsOrd f tp)
_ -> Intervals f ctx
-> (tp -> m (Maybe tp))
-> IntervalsMap f ctx tp
-> m (Maybe (IntervalsMap f ctx tp))
forall {k} (m :: * -> *) (f :: k -> *) (ctx :: Ctx k) tp.
(Monad m, OrdF f) =>
Intervals f ctx
-> (tp -> m (Maybe tp))
-> IntervalsMap f ctx tp
-> m (Maybe (IntervalsMap f ctx tp))
mapMIntersecting' (Assignment (IntervalF f) ctx -> Intervals f ctx
forall {k} (f :: k -> *) (ctx :: Ctx k).
Assignment (IntervalF f) ctx -> Intervals f ctx
Intervals Assignment (IntervalF f) ctx
rest) tp -> m (Maybe tp)
f) IntervalMap (Interval (AsOrd f tp)) (IntervalsMap f ctx tp)
IntervalMap (AsOrd f idx) (IntervalsMap f ctx tp)
ims
  case IntervalMap (Interval (AsOrd f tp)) (IntervalsMap f ctx tp) -> Int
forall k v. IntervalMap k v -> Int
IM.size IntervalMap (Interval (AsOrd f tp)) (IntervalsMap f ctx tp)
ims' of
    Int
0 -> Maybe (IntervalsMap f ctx tp) -> m (Maybe (IntervalsMap f ctx tp))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (IntervalsMap f ctx tp)
forall a. Maybe a
Nothing
    Int
_ -> Maybe (IntervalsMap f ctx tp) -> m (Maybe (IntervalsMap f ctx tp))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (IntervalsMap f ctx tp)
 -> m (Maybe (IntervalsMap f ctx tp)))
-> Maybe (IntervalsMap f ctx tp)
-> m (Maybe (IntervalsMap f ctx tp))
forall a b. (a -> b) -> a -> b
$ IntervalsMap f ctx tp -> Maybe (IntervalsMap f ctx tp)
forall a. a -> Maybe a
Just (IntervalMap (Interval (AsOrd f tp)) (IntervalsMap f ctx tp)
-> IntervalsMap f (ctx ::> tp) tp
forall {k} (f :: k -> *) (idx :: k) (ctx :: Ctx k) tp.
IntervalMap (AsOrd f idx) (IntervalsMap f ctx tp)
-> IntervalsMap f (ctx ::> idx) tp
IntervalsMapCons IntervalMap (Interval (AsOrd f tp)) (IntervalsMap f ctx tp)
ims')
mapMIntersecting' (Intervals Assignment (IntervalF f) ctx
Ctx.Empty) tp -> m (Maybe tp)
f (IntervalsMapHead tp
v) = (tp -> IntervalsMap f ctx tp)
-> Maybe tp -> Maybe (IntervalsMap f ctx tp)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap tp -> IntervalsMap f ctx tp
tp -> IntervalsMap f EmptyCtx tp
forall {k} tp (f :: k -> *). tp -> IntervalsMap f EmptyCtx tp
IntervalsMapHead (Maybe tp -> Maybe (IntervalsMap f ctx tp))
-> m (Maybe tp) -> m (Maybe (IntervalsMap f ctx tp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> tp -> m (Maybe tp)
f tp
v

-- | Adjust entries which intersect the given interval
mapMIntersecting ::
  Monad m =>
  OrdF f =>
  Intervals f (ctx Ctx.::> a) ->
  (tp -> m (Maybe tp)) ->
  IntervalsMap f (ctx Ctx.::> a) tp ->
  m (IntervalsMap f (ctx Ctx.::> a) tp)
mapMIntersecting :: forall {k} (m :: * -> *) (f :: k -> *) (ctx :: Ctx k) (a :: k) tp.
(Monad m, OrdF f) =>
Intervals f (ctx ::> a)
-> (tp -> m (Maybe tp))
-> IntervalsMap f (ctx ::> a) tp
-> m (IntervalsMap f (ctx ::> a) tp)
mapMIntersecting Intervals f (ctx ::> a)
i tp -> m (Maybe tp)
f IntervalsMap f (ctx ::> a) tp
ims = Intervals f (ctx ::> a)
-> (tp -> m (Maybe tp))
-> IntervalsMap f (ctx ::> a) tp
-> m (Maybe (IntervalsMap f (ctx ::> a) tp))
forall {k} (m :: * -> *) (f :: k -> *) (ctx :: Ctx k) tp.
(Monad m, OrdF f) =>
Intervals f ctx
-> (tp -> m (Maybe tp))
-> IntervalsMap f ctx tp
-> m (Maybe (IntervalsMap f ctx tp))
mapMIntersecting' Intervals f (ctx ::> a)
i tp -> m (Maybe tp)
f IntervalsMap f (ctx ::> a) tp
ims m (Maybe (IntervalsMap f (ctx ::> a) tp))
-> (Maybe (IntervalsMap f (ctx ::> a) tp)
    -> m (IntervalsMap f (ctx ::> a) tp))
-> m (IntervalsMap f (ctx ::> a) tp)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Just IntervalsMap f (ctx ::> a) tp
ims' -> IntervalsMap f (ctx ::> a) tp -> m (IntervalsMap f (ctx ::> a) tp)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return IntervalsMap f (ctx ::> a) tp
ims'
  Maybe (IntervalsMap f (ctx ::> a) tp)
Nothing -> IntervalsMap f (ctx ::> a) tp -> m (IntervalsMap f (ctx ::> a) tp)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (IntervalsMap f (ctx ::> a) tp
 -> m (IntervalsMap f (ctx ::> a) tp))
-> IntervalsMap f (ctx ::> a) tp
-> m (IntervalsMap f (ctx ::> a) tp)
forall a b. (a -> b) -> a -> b
$ IntervalMap (AsOrd f a) (IntervalsMap f ctx tp)
-> IntervalsMap f (ctx ::> a) tp
forall {k} (f :: k -> *) (idx :: k) (ctx :: Ctx k) tp.
IntervalMap (AsOrd f idx) (IntervalsMap f ctx tp)
-> IntervalsMap f (ctx ::> idx) tp
IntervalsMapCons IntervalMap (AsOrd f a) (IntervalsMap f ctx tp)
forall k v. IntervalMap k v
IM.empty


mapMIntersectingBase ::
  forall k v e m.
  Monad m =>
  IMG.Interval k e =>
  Ord k =>
  k ->
  (k -> v -> m (Maybe v)) ->
  IMG.IntervalMap k v ->
  m (IMG.IntervalMap k v)
mapMIntersectingBase :: forall k v e (m :: * -> *).
(Monad m, Interval k e, Ord k) =>
k
-> (k -> v -> m (Maybe v))
-> IntervalMap k v
-> m (IntervalMap k v)
mapMIntersectingBase k
k k -> v -> m (Maybe v)
f IntervalMap k v
im = do
  let (IntervalMap k v
pref, IntervalMap k v
inter, IntervalMap k v
suf) = IntervalMap k v
-> k -> (IntervalMap k v, IntervalMap k v, IntervalMap k v)
forall i k a.
(Interval i k, Ord i) =>
IntervalMap i a
-> i -> (IntervalMap i a, IntervalMap i a, IntervalMap i a)
IM.splitIntersecting IntervalMap k v
im k
k
  case IntervalMap k v -> Int
forall k v. IntervalMap k v -> Int
IM.size IntervalMap k v
inter of
    Int
0 -> IntervalMap k v -> m (IntervalMap k v)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return IntervalMap k v
im
    Int
_ -> do
      [(k, v)]
im' <- [Maybe (k, v)] -> [(k, v)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (k, v)] -> [(k, v)]) -> m [Maybe (k, v)] -> m [(k, v)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((k, v) -> m (Maybe (k, v))) -> [(k, v)] -> m [Maybe (k, v)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (k, v) -> m (Maybe (k, v))
go (IntervalMap k v -> [(k, v)]
forall k v. IntervalMap k v -> [(k, v)]
IM.toAscList IntervalMap k v
inter)
      IntervalMap k v -> m (IntervalMap k v)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (IntervalMap k v -> m (IntervalMap k v))
-> IntervalMap k v -> m (IntervalMap k v)
forall a b. (a -> b) -> a -> b
$ [(k, v)] -> IntervalMap k v
forall k e v. Interval k e => [(k, v)] -> IntervalMap k v
IM.fromDistinctAscList (IntervalMap k v -> [(k, v)]
forall k v. IntervalMap k v -> [(k, v)]
IM.toAscList IntervalMap k v
pref [(k, v)] -> [(k, v)] -> [(k, v)]
forall a. [a] -> [a] -> [a]
++ [(k, v)]
im' [(k, v)] -> [(k, v)] -> [(k, v)]
forall a. [a] -> [a] -> [a]
++ IntervalMap k v -> [(k, v)]
forall k v. IntervalMap k v -> [(k, v)]
IM.toAscList IntervalMap k v
suf)
  where
    go :: (k, v) -> m (Maybe (k, v))
    go :: (k, v) -> m (Maybe (k, v))
go (k
k', v
v) = k -> v -> m (Maybe v)
f k
k' v
v m (Maybe v) -> (Maybe v -> m (Maybe (k, v))) -> m (Maybe (k, v))
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just v
v' -> Maybe (k, v) -> m (Maybe (k, v))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (k, v) -> m (Maybe (k, v)))
-> Maybe (k, v) -> m (Maybe (k, v))
forall a b. (a -> b) -> a -> b
$ (k, v) -> Maybe (k, v)
forall a. a -> Maybe a
Just (k
k', v
v')
      Maybe v
Nothing -> Maybe (k, v) -> m (Maybe (k, v))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (k, v)
forall a. Maybe a
Nothing


mergeIntervals ::
  Ord a =>
  IM.Interval a ->
  IM.Interval a ->
  IM.Interval a
mergeIntervals :: forall a. Ord a => Interval a -> Interval a -> Interval a
mergeIntervals Interval a
i1 Interval a
i2 = case (Bool
leftClosed, Bool
rightClosed) of
  (Bool
True, Bool
True) -> a -> a -> Interval a
forall a. a -> a -> Interval a
IM.ClosedInterval a
lower a
upper
  (Bool
False, Bool
True) -> a -> a -> Interval a
forall a. a -> a -> Interval a
IM.IntervalOC a
lower a
upper
  (Bool
True, Bool
False) -> a -> a -> Interval a
forall a. a -> a -> Interval a
IM.IntervalCO a
lower a
upper
  (Bool
False, Bool
False) -> a -> a -> Interval a
forall a. a -> a -> Interval a
IM.OpenInterval a
lower a
upper
  where
    leftClosed :: Bool
leftClosed = (Interval a -> Bool
forall a. Interval a -> Bool
IM.leftClosed Interval a
i1 Bool -> Bool -> Bool
&& a
lo1 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
lo2) Bool -> Bool -> Bool
|| (Interval a -> Bool
forall a. Interval a -> Bool
IM.leftClosed Interval a
i2 Bool -> Bool -> Bool
&& a
lo2 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
lo1)
    rightClosed :: Bool
rightClosed = (Interval a -> Bool
forall a. Interval a -> Bool
IM.rightClosed Interval a
i1 Bool -> Bool -> Bool
&& a
hi2 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
hi1) Bool -> Bool -> Bool
|| (Interval a -> Bool
forall a. Interval a -> Bool
IM.rightClosed Interval a
i2 Bool -> Bool -> Bool
&& a
hi1 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
hi2)
    lo1 :: a
lo1 = Interval a -> a
forall a. Interval a -> a
IM.lowerBound Interval a
i1
    lo2 :: a
lo2 = Interval a -> a
forall a. Interval a -> a
IM.lowerBound Interval a
i2
    hi1 :: a
hi1 = Interval a -> a
forall a. Interval a -> a
IM.upperBound Interval a
i1
    hi2 :: a
hi2 = Interval a -> a
forall a. Interval a -> a
IM.upperBound Interval a
i2
    lower :: a
lower = a -> a -> a
forall a. Ord a => a -> a -> a
min a
lo1 a
lo2
    upper :: a
upper = a -> a -> a
forall a. Ord a => a -> a -> a
max a
hi1 a
hi2

mergeIntervalsF ::
  OrdF f =>
  IntervalF f a ->
  IntervalF f a ->
  IntervalF f a
mergeIntervalsF :: forall k (f :: k -> *) (tp :: k).
OrdF f =>
IntervalF f tp -> IntervalF f tp -> IntervalF f tp
mergeIntervalsF (IntervalF Interval (AsOrd f a)
i1) (IntervalF Interval (AsOrd f a)
i2) = Interval (AsOrd f a) -> IntervalF f a
forall {k} (f :: k -> *) (tp :: k).
Interval (AsOrd f tp) -> IntervalF f tp
IntervalF (Interval (AsOrd f a)
-> Interval (AsOrd f a) -> Interval (AsOrd f a)
forall a. Ord a => Interval a -> Interval a -> Interval a
mergeIntervals Interval (AsOrd f a)
i1 Interval (AsOrd f a)
i2)