SemiRepresentable

SemiRepresentable.hs

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
module SemiRepresentable where

import qualified Data.Map as M
import Numeric.Natural
import qualified Data.Set as S
import Data.These
import Data.Semigroup


class Semigroup (KeyRange g) => SemiDistributive g where
  type KeyRange g :: *
  keyRange :: g a -> KeyRange g
  -- laws
  -- semidistribute range == collect range id
  -- semidistribute range . semidistribute range == fmap (Just . Just)
  semidistribute :: Functor f => KeyRange g -> f (g a) -> g (f (Maybe a))
  semidistribute rng fga = semicollect rng id fga
  -- laws
  -- semicollect range f == semidistribute range . fmap f
  semicollect :: Functor f => KeyRange g -> (a -> g b) -> f a -> g (f (Maybe b))
  semicollect rng f = semidistribute rng . fmap f

instance Ord k => SemiDistributive (M.Map k) where
  type instance KeyRange (M.Map k) = S.Set k
  keyRange :: M.Map k a -> S.Set k
  keyRange = S.fromList . M.keys
  semidistribute :: forall f a. Functor f => S.Set k -> f (M.Map k a) -> M.Map k (f (Maybe a))
  semidistribute keys fma =
      foldMap build keys
    where
      build :: k -> M.Map k (f (Maybe a))
      build k = M.singleton k $ fmap (M.lookup k) fma

safeIx :: Int -> [a] -> Maybe a
safeIx n xs
  | n <= length xs = Just (xs !! n)
  | otherwise = Nothing

instance SemiDistributive [] where
  type instance KeyRange [] = Max Natural
  keyRange :: [a] -> Max Natural
  keyRange = Max . fromIntegral . length
  semidistribute :: forall f a. Functor f => Max Natural -> f [a] -> [f (Maybe a)]
  semidistribute (Max n) fa = fmap go [0..n-1]
    where
      go :: Natural -> f (Maybe a)
      go n = fmap (safeIx $ fromIntegral n) fa

class SemiDistributive g => SemiRepresentable g where
  type Key g :: *
  semitabulate :: KeyRange g -> (Key g -> a) -> g a
  semiindex :: g a -> Key g -> Maybe a

instance SemiRepresentable [] where
  type instance Key [] = Int
  semitabulate (Max n) f = fmap f [0..fromIntegral n - 1]
  semiindex ga i = safeIx i ga


instance Ord k => SemiRepresentable (M.Map k) where
  type instance Key (M.Map k) = k
  semitabulate keys f = foldMap (\k -> M.singleton k (f k)) keys
  semiindex = flip M.lookup

align  :: (Semigroup (Key g), SemiRepresentable g) => g a -> g b -> g (These a b)
align a b =
    semitabulate (keyRange a <> keyRange b) (\k -> toThese (semiindex a k) (semiindex b k))
  where
    toThese (Just a) (Just b) = These a b
    toThese (Just a) Nothing = This a
    toThese Nothing (Just b) = That b