Add Data.Type.Functor.Map

src/Data/Type/Functor/Map.hs

@@ -0,0 +1,196 @@
+{- This module provides type-level finite maps.
+The implementation is similar to that shown in the paper.
+ "Embedding effect systems in Haskell" Orchard, Petricek 2014  -}
+
+{-# LANGUAGE TypeOperators, PolyKinds, DataKinds, KindSignatures,
+             TypeFamilies, UndecidableInstances, MultiParamTypeClasses,
+             FlexibleInstances, GADTs, FlexibleContexts, ScopedTypeVariables,
+             ConstraintKinds, RankNTypes #-}
+
+module Data.Type.Functor.Map
+  (Mapping(..), Union, Unionable, union, Var(..), Map(..), fromSimple, toSimple,
+   traverseValues, mapValues, Combine, Combinable(..), Cmp, Nubable, nub,
+   Lookup, Member, (:\), Split, split, IsMap, AsMap, asMap, Submap, submap)
+   where
+
+import GHC.TypeLits
+import Data.Functor.Identity (Identity(..))
+
+import Data.Type.Bool
+import Data.Type.Equality
+import Data.Type.Set (Cmp, Proxy(..), Flag(..), Sort, Filter, (:++))
+
+import Data.Type.Map.Internal (IsMap, AsMap, Mapping(..), Combine, Nub,
+                               Show'(..), Var(..), Union, (:\), Lookup, Member)
+import qualified Data.Type.Map.Internal as Simple
+
+-- import qualified Data.Type.M
+
+{- Throughout, type variables
+   'k' ranges over "keys"
+   'v'  ranges over "values"
+   'kvp' ranges over "key-value-pairs"
+   'm', 'n' range over "maps" -}
+
+-----------------------------------------------------------------
+-- Value-level map with a type-level representation
+
+{-|
+A value-level heterogenously-typed Map (with type-level representation in terms
+of lists).
+
+The map is parameterised by a functor @f@ from the universe @u@ to concrete
+types. For example, use 'Identity' for a normal heterogeneous map, or
+'Data.Functor.Const.Const a' for a homogeneous map with values of type @a@.
+-}
+data Map (f :: u -> *) (n :: [Mapping Symbol u]) where
+    Empty :: Map f '[]
+    Ext :: Var k -> f v -> Map f m -> Map f ((k :-> v) ': m)
+
+{-| At the value level, noramlise the list form to the map form -}
+asMap :: (Sortable s, Nubable f (Sort s)) => Map f s -> Map f (AsMap s)
+asMap x = nub (quicksort x)
+
+-- | Convert from a simple 'Simple.Map' to a 'Map' in 'Identity'.
+fromSimple :: Simple.Map m -> Map Identity m
+fromSimple Simple.Empty = Empty
+fromSimple (Simple.Ext k v s) = Ext k (Identity v) (fromSimple s)
+
+-- | Convert from a 'Map' in 'Identity' to a simple 'Simple.Map'.
+toSimple :: Map Identity m -> Simple.Map m
+toSimple Empty = Simple.Empty
+toSimple (Ext k (Identity v) s) = Simple.Ext k v (toSimple s)
+
+-- | Analogous to 'traverse', but the given function is a natural transformation
+-- from @f@ to @t . g@.
+traverseValues
+  :: (Applicative t)
+  => (forall a. f a -> t (g a)) -> Map f m -> t (Map g m)
+traverseValues f Empty = pure Empty
+traverseValues f (Ext k v s) =
+  Ext k <$> f v <*> traverseValues f s
+
+-- | Analogous to 'fmap', but the given function is a natural transformation
+-- from @f@ to @g@.
+mapValues :: (forall a. f a -> g a) -> Map f m -> Map g m
+mapValues f = runIdentity . traverseValues (Identity . f)
+
+instance Show (Map f '[]) where
+    show Empty = "{}"
+
+instance (KnownSymbol k, Show (f v), Show' (Map f s)) => Show (Map f ((k :-> v) ': s)) where
+    show (Ext k v s) = "{" ++ show k ++ " :-> " ++ show v ++ (show' s) ++ "}"
+
+instance Show' (Map f '[]) where
+    show' Empty = ""
+instance (KnownSymbol k, Show (f v), Show' (Map f s)) => Show' (Map f ((k :-> v) ': s)) where
+    show' (Ext k v s) = ", " ++ show k ++ " :-> " ++ show v ++ (show' s)
+
+instance Eq (Map f '[]) where
+    Empty == Empty = True
+
+instance (KnownSymbol k, Eq (Var k), Eq (f v), Eq (Map f s)) => Eq (Map f ((k :-> v) ': s)) where
+    (Ext k v m) == (Ext k' v' m') = k == k' && v == v' && m == m'
+
+{-| Union of two finite maps -}
+union :: (Unionable f s t) => Map f s -> Map f t -> Map f (Union s t)
+union s t = nub (quicksort (append s t))
+
+type Unionable f s t = (Nubable f (Sort (s :++ t)), Sortable (s :++ t))
+
+append :: Map f s -> Map f t -> Map f (s :++ t)
+append Empty x = x
+append (Ext k v xs) ys = Ext k v (append xs ys)
+
+{-| Value-level quick sort that respects the type-level ordering -}
+class Sortable xs where
+    quicksort :: Map f xs -> Map f (Sort xs)
+
+instance Sortable '[] where
+    quicksort Empty = Empty
+
+instance (Sortable (Filter FMin (k :-> v) xs),
+          Sortable (Filter FMax (k :-> v) xs), FilterV FMin k v xs, FilterV FMax k v xs) => Sortable ((k :-> v) ': xs) where
+    quicksort (Ext k v xs) = ((quicksort (less k v xs)) `append` (Ext k v Empty)) `append` (quicksort (more k v xs))
+                              where less = filterV (Proxy::(Proxy FMin))
+                                    more = filterV (Proxy::(Proxy FMax))
+
+{- Filter out the elements less-than or greater-than-or-equal to the pivot -}
+class FilterV (f::Flag) k v xs where
+    filterV :: Proxy f -> Var k -> g v -> Map g xs -> Map g (Filter f (k :-> v) xs)
+
+instance FilterV f k v '[] where
+    filterV _ k v Empty      = Empty
+
+instance (Conder ((Cmp x (k :-> v)) == LT), FilterV FMin k v xs) => FilterV FMin k v (x ': xs) where
+    filterV f@Proxy k v (Ext k' v' xs) = cond (Proxy::(Proxy ((Cmp x (k :-> v)) == LT)))
+                                        (Ext k' v' (filterV f k v xs)) (filterV f k v xs)
+
+instance (Conder (((Cmp x (k :-> v)) == GT) || ((Cmp x (k :-> v)) == EQ)), FilterV FMax k v xs) => FilterV FMax k v (x ': xs) where
+    filterV f@Proxy k v (Ext k' v' xs) = cond (Proxy::(Proxy (((Cmp x (k :-> v)) == GT) || ((Cmp x (k :-> v)) == EQ))))
+                                        (Ext k' v' (filterV f k v xs)) (filterV f k v xs)
+
+class Combinable f t t' where
+  combine :: f t -> f t' -> f (Combine t t')
+
+class Nubable f t where
+    nub :: Map f t -> Map f (Nub t)
+
+instance Nubable f '[] where
+    nub Empty = Empty
+
+instance Nubable f '[e] where
+    nub (Ext k v Empty) = Ext k v Empty
+
+instance {-# OVERLAPPABLE #-}
+     (Nub (e ': f ': s) ~ (e ': Nub (f ': s)),
+              Nubable g (f ': s)) => Nubable g (e ': f ': s) where
+    nub (Ext k v (Ext k' v' s)) = Ext k v (nub (Ext k' v' s))
+
+instance {-# OVERLAPS #-}
+    (Combinable f v v', Nubable f ((k :-> Combine v v') ': s)) => Nubable f ((k :-> v) ': (k :-> v') ': s) where
+    nub (Ext k v (Ext k' v' s)) = nub (Ext k (combine v v') s)
+
+
+class Conder g where
+    cond :: Proxy g -> Map f s -> Map f t -> Map f (If g s t)
+
+instance Conder True where
+    cond _ s t = s
+
+instance Conder False where
+    cond _ s t = t
+
+
+{-| Splitting a union of maps, given the maps we want to split it into -}
+class Split s t st where
+   -- where st ~ Union s t
+   split :: Map f st -> (Map f s, Map f t)
+
+instance Split '[] '[] '[] where
+   split Empty = (Empty, Empty)
+
+instance {-# OVERLAPPABLE #-} Split s t st => Split (x ': s) (x ': t) (x ': st) where
+   split (Ext k v st) = let (s, t) = split st
+                        in (Ext k v s, Ext k v t)
+
+instance {-# OVERLAPS #-} Split s t st => Split (x ': s) t (x ': st) where
+   split (Ext k v st) = let (s, t) = split st
+                        in  (Ext k v s, t)
+
+instance {-# OVERLAPS #-} (Split s t st) => Split s (x ': t) (x ': st) where
+   split (Ext k v st) = let (s, t) = split st
+                        in  (s, Ext k v t)
+
+{-| Construct a submap 's' from a supermap 't' -}
+class Submap s t where
+   submap :: Map f t -> Map f s
+
+instance Submap '[] '[] where
+   submap xs = Empty
+
+instance {-# OVERLAPPABLE #-} Submap s t => Submap s (x ': t) where
+   submap (Ext _ _ xs) = submap xs
+
+instance {-# OVERLAPS #-} Submap s t => Submap  (x ': s) (x ': t) where
+   submap (Ext k v xs) = Ext k v (submap xs)

src/Data/Type/Map.hs

@@ -19,6 +19,9 @@ import GHC.TypeLits
 import Data.Type.Bool
 import Data.Type.Equality
 import Data.Type.Set (Cmp, Proxy(..), Flag(..), Sort, Filter, (:++))
+import Data.Type.Map.Internal (IsMap, AsMap, Var(..), Map(..), Mapping(..),
+                               Combine, Nub, Show'(..), Union, (:\), Lookup,
+                               Member)
 
 {- Throughout, type variables
    'k' ranges over "keys"
@@ -123,8 +126,6 @@ instance Show (Map '[]) where
 instance (KnownSymbol k, Show v, Show' (Map s)) => Show (Map ((k :-> v) ': s)) where
     show (Ext k v s) = "{" ++ show k ++ " :-> " ++ show v ++ show' s ++ "}"
 
-class Show' t where
-    show' :: t -> String
 instance Show' (Map '[]) where
     show' Empty = ""
 instance (KnownSymbol k, Show v, Show' (Map s)) => Show' (Map ((k :-> v) ': s)) where

src/Data/Type/Map/Internal.hs

@@ -0,0 +1,70 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE PolyKinds #-}
+module Data.Type.Map.Internal where
+
+import GHC.TypeLits
+
+import Data.Type.Set (Cmp, Proxy(..), Flag(..), Sort, Filter, (:++))
+
+-- Mappings
+infixr 4 :->
+{-| A key-value pair -}
+data Mapping k v = k :-> v
+
+{-| Predicate to check if in normalised map form -}
+type IsMap s = (s ~ Nub (Sort s))
+
+{-| At the type level, normalise the list form to the map form -}
+type AsMap s = Nub (Sort s)
+
+{-| Open type family for combining values in a map (that have the same key) -}
+type family Combine (a :: v) (b :: v) :: v
+
+{-| Apply 'Combine' to values with matching key (removes duplicate keys) -}
+type family Nub t where
+   Nub '[]                             = '[]
+   Nub '[kvp]                          = '[kvp]
+   Nub ((k :-> v1) ': (k :-> v2) ': m) = Nub ((k :-> Combine v1 v2) ': m)
+   Nub (kvp1 ': kvp2 ': s)             = kvp1 ': Nub (kvp2 ': s)
+
+class Show' t where
+    show' :: t -> String
+
+{-| Union of two finite maps -}
+type Union m n = Nub (Sort (m :++ n))
+
+{-| Delete elements from a map by key -}
+type family (m :: [Mapping k v]) :\ (c :: k) :: [Mapping k v] where
+     '[]               :\ k = '[]
+     ((k :-> v) ': m)  :\ k = m :\ k
+     (kvp ': m)        :\ k = kvp ': (m :\ k)
+
+{-| Lookup elements from a map -}
+type family Lookup (m :: [Mapping k v]) (c :: k) :: Maybe v where
+            Lookup '[]              k = Nothing
+            Lookup ((k :-> v) ': m) k = Just v
+            Lookup (kvp ': m)       k = Lookup m k
+
+{-| Membership test -}
+type family Member (c :: k) (m :: [Mapping k v]) :: Bool where
+            Member k '[]              = False
+            Member k ((k :-> v) ': m) = True
+            Member k (kvp ': m)       = Member k m
+
+
+{-| Pair a symbol (representing a variable) with a type -}
+data Var (k :: Symbol) = Var
+
+instance KnownSymbol k => Show (Var k) where
+    show = symbolVal
+
+{-| A value-level heterogenously-typed Map (with type-level representation in terms of lists) -}
+data Map (n :: [Mapping Symbol *]) where
+    Empty :: Map '[]
+    Ext :: Var k -> v -> Map m -> Map ((k :-> v) ': m)

stack.yaml

@@ -1,7 +1,7 @@
 # For more information, see: https://github.com/commercialhaskell/stack/wiki/stack.yaml
 
 # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
-resolver: nightly-2016-07-18
+resolver: nightly-2017-08-24
 
 # Local packages, usually specified by relative directory name
 packages:

type-level-sets.cabal

@@ -1,5 +1,5 @@
 name:                   type-level-sets
-version:                0.8.7.0
+version:                0.9.0
 synopsis:               Type-level sets and finite maps (with value-level counterparts)
 description:            
    This package provides type-level sets (no duplicates, sorted to provide a normal form) via 'Set' and type-level
@@ -84,6 +84,9 @@ library
 
   exposed-modules:      Data.Type.Set
                         Data.Type.Map
+                        Data.Type.Functor.Map
+  other-modules:        Data.Type.Map.Internal
 
   build-depends:        base < 5,
-                        ghc-prim
+                        ghc-prim,
+                        transformers >= 0.5