{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
module Data.Comp.Multi.Mapping
( Numbered (..)
, unNumbered
, number
, HTraversable ()
, Mapping (..)
, lookupNumMap) where
import Data.Comp.Multi.HFunctor
import Data.Comp.Multi.HTraversable
import Data.Kind
import Control.Monad.State
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
data Numbered a i = Numbered Int (a i)
unNumbered :: Numbered a :-> a
unNumbered :: forall (a :: * -> *). Numbered a :-> a
unNumbered (Numbered Int
_ a i
x) = a i
x
number :: HTraversable f => f a :-> f (Numbered a)
number :: forall (f :: (* -> *) -> * -> *) (a :: * -> *).
HTraversable f =>
f a :-> f (Numbered a)
number f a i
x = forall s a. State s a -> s -> a
evalState (forall (t :: (* -> *) -> * -> *) (m :: * -> *) (a :: * -> *)
(b :: * -> *).
(HTraversable t, Monad m) =>
NatM m a b -> NatM m (t a) (t b)
hmapM forall {m :: * -> *} {a :: * -> *} {i}.
MonadState Int m =>
a i -> m (Numbered a i)
run f a i
x) Int
0 where
run :: a i -> m (Numbered a i)
run a i
b = do Int
n <- forall s (m :: * -> *). MonadState s m => m s
get
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Int
nforall a. Num a => a -> a -> a
+Int
1)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (a :: * -> *) i. Int -> a i -> Numbered a i
Numbered Int
n a i
b
infix 1 |->
infixr 0 &
class Mapping m (k :: Type -> Type) | m -> k where
(&) :: m v -> m v -> m v
(|->) :: k i -> v -> m v
empty :: m v
prodMap :: v1 -> v2 -> m v1 -> m v2 -> m (v1, v2)
findWithDefault :: a -> k i -> m a -> a
newtype NumMap (k :: Type -> Type) v = NumMap (IntMap v) deriving forall a b. a -> NumMap k b -> NumMap k a
forall a b. (a -> b) -> NumMap k a -> NumMap k b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (k :: * -> *) a b. a -> NumMap k b -> NumMap k a
forall (k :: * -> *) a b. (a -> b) -> NumMap k a -> NumMap k b
<$ :: forall a b. a -> NumMap k b -> NumMap k a
$c<$ :: forall (k :: * -> *) a b. a -> NumMap k b -> NumMap k a
fmap :: forall a b. (a -> b) -> NumMap k a -> NumMap k b
$cfmap :: forall (k :: * -> *) a b. (a -> b) -> NumMap k a -> NumMap k b
Functor
lookupNumMap :: a -> Int -> NumMap t a -> a
lookupNumMap :: forall a (t :: * -> *). a -> Int -> NumMap t a -> a
lookupNumMap a
d Int
k (NumMap IntMap a
m) = forall a. a -> Int -> IntMap a -> a
IntMap.findWithDefault a
d Int
k IntMap a
m
instance Mapping (NumMap k) (Numbered k) where
NumMap IntMap v
m1 & :: forall v. NumMap k v -> NumMap k v -> NumMap k v
& NumMap IntMap v
m2 = forall (k :: * -> *) v. IntMap v -> NumMap k v
NumMap (forall a. IntMap a -> IntMap a -> IntMap a
IntMap.union IntMap v
m1 IntMap v
m2)
Numbered Int
k k i
_ |-> :: forall i v. Numbered k i -> v -> NumMap k v
|-> v
v = forall (k :: * -> *) v. IntMap v -> NumMap k v
NumMap forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> IntMap a
IntMap.singleton Int
k v
v
empty :: forall v. NumMap k v
empty = forall (k :: * -> *) v. IntMap v -> NumMap k v
NumMap forall a. IntMap a
IntMap.empty
findWithDefault :: forall a i. a -> Numbered k i -> NumMap k a -> a
findWithDefault a
d (Numbered Int
i k i
_) NumMap k a
m = forall a (t :: * -> *). a -> Int -> NumMap t a -> a
lookupNumMap a
d Int
i NumMap k a
m
prodMap :: forall v1 v2.
v1 -> v2 -> NumMap k v1 -> NumMap k v2 -> NumMap k (v1, v2)
prodMap v1
p v2
q (NumMap IntMap v1
mp) (NumMap IntMap v2
mq) = forall (k :: * -> *) v. IntMap v -> NumMap k v
NumMap forall a b. (a -> b) -> a -> b
$ forall a b c.
(Int -> a -> b -> Maybe c)
-> (IntMap a -> IntMap c)
-> (IntMap b -> IntMap c)
-> IntMap a
-> IntMap b
-> IntMap c
IntMap.mergeWithKey forall {p} {a} {b}. p -> a -> b -> Maybe (a, b)
merge
(forall a b. (a -> b) -> IntMap a -> IntMap b
IntMap.map (,v2
q)) (forall a b. (a -> b) -> IntMap a -> IntMap b
IntMap.map (v1
p,)) IntMap v1
mp IntMap v2
mq
where merge :: p -> a -> b -> Maybe (a, b)
merge p
_ a
p b
q = forall a. a -> Maybe a
Just (a
p,b
q)