Something a bit like modules

Modules.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Main where

import Data.Function (on)
import Data.List (deleteBy, insertBy)
import Data.Maybe (fromMaybe)
import Data.Proxy (Proxy(..))

-- | Reified type class dictionary
--
-- This could be taken from the @constraints@ package.
data Dict c where
  Dict :: c => Dict c

-- | It will be useful to be able to talk about lifting constraints
-- over type constructors if we want to be able to put constraints like
-- 'Show' on the types which implement our module signatures.
class Lifted c f where
  lifted :: Dict (c a) -> Dict (c (f a))

-- | Helper function for using 'Lifted'.
lifting
  :: forall c f a r
   . (Lifted c f, c a)
  => Proxy (c (f a))
  -> (c (f a) => r)
  -> r
lifting _ r =
  case lifted (Dict :: Dict (c a)) of
    (Dict :: Dict (c (f a))) -> r

-- | A signature for a map module implementation.
data MapDefns map k = MapDefns
  { mapEmpty :: forall a. map a
  , mapInsert :: forall a. k -> a -> map a -> map a
  , mapLookup :: forall a. k -> map a -> Maybe a
  , mapDelete :: forall a. k -> map a -> map a
  , mapModify :: forall a. k -> (Maybe a -> a) -> map a -> map a
  }

-- | An implementation of the 'MapDefns' signature.
--
-- Note the type 'map' (which appeared as a type argument to
-- 'MapDefns') is hidden existentially here.
--
-- We also add 'Show' and 'Eq' constraints on the 'map' type,
-- but note that 'Lifted' allows us to require the value types in the
-- 'map' to also be 'Show'able and 'Eq'uatable.
data MapModule k where
  MapModule :: (Lifted Show map, Lifted Eq map)
            => MapDefns map k
            -> MapModule k

-- | We can define functions which are polymorphic in the module
-- implementation, but we must use 'MapDefns', so that the 'map' type variable
-- is brought into scope.
mapSingleton :: MapDefns map k -> k -> a -> map a
mapSingleton MapDefns{..} k a = mapInsert k a mapEmpty

-- | An implementation of the module signature based on association
-- lists.
assoc :: forall k. (Show k, Eq k) => MapModule k
assoc = MapModule MapDefns{..} where
  mapEmpty :: Assoc k a
  mapEmpty = Assoc []

  mapInsert :: k -> a -> Assoc k a -> Assoc k a
  mapInsert k a = Assoc . ((k, a) :) . runAssoc

  mapLookup :: k -> Assoc k a -> Maybe a
  mapLookup k = lookup k . runAssoc

  mapDelete :: k -> Assoc k a -> Assoc k a
  mapDelete k = Assoc . deleteBy ((==) `on` fst) (k, undefined) . runAssoc

  mapModify :: k -> (Maybe a -> a) -> Assoc k a -> Assoc k a
  mapModify k f = Assoc . go . runAssoc where
    go [] = [(k, f Nothing)]
    go ((k1, a) : xs)
      | k == k1 = (k1, f (Just a)) : xs
      | otherwise = (k1, a) : go xs

-- | Functors are just functions
--
-- For example, we can build a map from keys which are tuples if we have
-- implementations of maps for each component of the tuple, since we can
-- simply nest the maps.
mapTuple :: forall k1 k2. MapModule k1 -> MapModule k2 -> MapModule (k1, k2)
mapTuple (MapModule (MapDefns { mapEmpty  = mapEmptyL
                              , mapLookup = mapLookupL
                              , mapModify = mapModifyL
                              } :: MapDefns f k1))
         (MapModule r@(MapDefns { mapEmpty  = mapEmptyR
                                , mapInsert = mapInsertR
                                , mapLookup = mapLookupR
                                , mapDelete = mapDeleteR
                                , mapModify = mapModifyR
                                } :: MapDefns g k2))
    = MapModule MapDefns{..}
  where
    mapEmpty :: Compose f g a
    mapEmpty = Compose mapEmptyL

    mapInsert :: (k1, k2) -> a -> Compose f g a -> Compose f g a
    mapInsert (k1, k2) a = Compose . mapModifyL k1 (mapInsertR k2 a . fromMaybe mapEmptyR) . runCompose

    mapLookup :: (k1, k2) -> Compose f g a -> Maybe a
    mapLookup (k1, k2) (Compose fga) = do
      ga <- mapLookupL k1 fga
      mapLookupR k2 ga

    mapDelete :: (k1, k2) -> Compose f g a -> Compose f g a
    mapDelete (k1, k2) = Compose . mapModifyL k1 (maybe mapEmptyR (mapDeleteR k2)) . runCompose

    mapModify :: (k1, k2) -> (Maybe a -> a) -> Compose f g a -> Compose f g a
    mapModify (k1, k2) f = Compose . mapModifyL k1 proceed . runCompose
      where
        proceed Nothing = mapSingleton r k2 (f Nothing) -- Left key not in left map
        proceed (Just m) = mapModifyR k2 f m

main :: IO ()
main = do
  -- "Open" the module by using record wildcards
  case mapTuple assoc assoc of
    -- The type annotation is not necessary here in general -
    -- we just need it to disambiguate the call to 'lifting'.
    MapModule (MapDefns{..} :: MapDefns map (Int, Char)) -> do
      let m1 = mapEmpty
          m2 = mapInsert (0, 'a') "foo" m1
          m3 = mapInsert (0, 'b') "bar" m2
          m4 = mapDelete (0, 'a') m3
      lifting (Proxy :: Proxy (Show (map String))) print m4
      print (mapLookup (0, 'b') m4)

-- Guts

-- | An association list implementation
newtype Assoc k a = Assoc { runAssoc :: [(k, a)] } deriving (Show, Eq)

instance Show k => Lifted Show (Assoc k) where
  lifted Dict = Dict

instance Eq k => Lifted Eq (Assoc k) where
  lifted Dict = Dict

-- | Composition of functors
data Compose f g a = Compose { runCompose :: f (g a) } deriving (Show, Eq)

instance forall f g. (Lifted Show f, Lifted Show g) => Lifted Show (Compose f g) where
  lifted d = case lifted (lifted d) of
               (Dict :: Dict (Show (f (g a)))) -> Dict

instance forall f g. (Lifted Eq f, Lifted Eq g) => Lifted Eq (Compose f g) where
  lifted d = case lifted (lifted d) of
               (Dict :: Dict (Eq (f (g a)))) -> Dict