Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
SemiRepresentable
{-# 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment