M

Mip.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -W #-}
module Mip where

import           Control.Applicative (Applicative(..))
import qualified Control.Lens as L
import           Control.Lens.Operators
import           Data.Semigroup (Semigroup(..))
import           Data.Monoid (Monoid(..))


data Mip k a = Empty | Mip k a
    deriving (Show, Read, Eq, Ord)

instance Functor (Mip k) where
  fmap _ Empty     = Empty
  fmap f (Mip k a) = Mip k (f a)

L.makePrisms ''Mip

instance Semigroup (Mip k a) where
  Empty <> x = x
  x     <> _ = x

instance Monoid (Mip k a) where
  mempty  = Empty
  mappend = (<>)

instance L.AsEmpty (Mip k a) where
  _Empty = Mip._Empty

lookup :: Eq k => k -> Mip k a -> Maybe a
lookup _      Empty = Nothing
lookup k' (Mip k a) = bool Nothing (Just a) (k == k')

insert :: Eq k => k -> a -> Mip k a -> Mip k a
insert k a        Empty = Mip k a
insert k a x@(Mip k' _) = bool x (Mip k a) (k == k')

delete :: Eq k => k -> Mip k a -> Mip k a
delete _        Empty = Empty
delete k' x@(Mip k _) = bool x Empty (k == k')

bool f t p = if p then t else f

type instance L.Index (Mip k a) = k
type instance L.IxValue (Mip k a) = a

instance (Applicative f, Eq k) => L.Ixed f (Mip k a) where
  ix = L.ixAt

instance Eq k => L.At (Mip k a) where
  at k f m = L.indexed f k mv <&> \r -> case r of
    Nothing -> maybe m (const (Mip.delete k m)) mv
    Just v  -> Mip.insert k v m
   where
    mv = Mip.lookup k m

keys :: Mip k a -> Maybe k
keys Empty     = Nothing
keys (Mip k _) = Just k

elems :: Mip k a -> Maybe a
elems Empty     = Nothing
elems (Mip _ a) = Just a

assocs :: Mip k a -> Maybe (k, a)
assocs Empty     = Nothing
assocs (Mip k v) = Just (k, v)