type-level maps and maybes

diff --git a/Data/HList/Graph.hs b/Data/HList/Graph.hs
index 7a833ea4ec2e10eadbf9345f1ff575825610a750..c3fcf87eb750f229c85951d185a25c4814ab2038 100644 (file)
--- a/Data/HList/Graph.hs
+++ b/Data/HList/Graph.hs
@@ -1,25 +1,37 @@
 {-# LANGUAGE
   EmptyDataDecls,
-  FlexibleContexts,
-  FlexibleInstances,
-  MultiParamTypeClasses,
   TypeFamilies
   #-}
 module Data.HList.Graph
-    ( Graph(..)
-    , NodeSet
-    , NodeIDSet
-    , Node(..)
-    , LPath(..)
+    ( Context
+    , Graph
 
+    , Empty
     , IsEmpty
-
-    , NodeIDA
+--    , Match
     )
     where
 
 import Data.HList.Prelude
+import Types.Data.Bool
+
+-- Graph is a map from node ID to context
+data Context preNodes node sucNodes
+data Graph nodeMap
+
+-- Empty
+type Empty = Graph Nil
+
+-- IsEmpty
+type family   IsEmpty g
+type instance IsEmpty (Graph Nil)         = True
+type instance IsEmpty (Graph (Cons x xs)) = False
+
+-- Match
+--type Match n g
+--    = 
 
+{-
 -- NodeSet
 class    NodeSet ns
 instance NodeSet Nil
@@ -57,3 +69,4 @@ class ( NodeSet (Nodes g)
 
 -- IsEmpty
 type family IsEmpty g
+-}
\ No newline at end of file

diff --git a/Data/HList/Prelude.hs b/Data/HList/Prelude.hs
index 3a46616662132331d8479a57ee70692cf9eed6ef..d50ad25e081c6e129442081d239f29b244f35543 100644 (file)
--- a/Data/HList/Prelude.hs
+++ b/Data/HList/Prelude.hs
@@ -342,4 +342,14 @@ instance TypeCast'' t a b => TypeCast' t a b
 instance TypeCast'' () a a
     where
       typeCast'' _ x = x
+
+
+class MemberT e l where
+    type Member e l
+
+instance MemberT e Nil where
+    type Member e Nil = False
+
+instance MemberT e (Cons e' l) where
+    type Member e (Cons e' l) = TypeEq e e' b => b
 -}
\ No newline at end of file

diff --git a/Types/Data/Map.hs b/Types/Data/Map.hs
new file mode 100644 (file)
index 0000000..95fe59b
--- /dev/null
+++ b/Types/Data/Map.hs
@@ -0,0 +1,144 @@
+{-# LANGUAGE
+  EmptyDataDecls,
+  TypeFamilies,
+  TypeOperators,
+  UndecidableInstances
+  #-}
+module Types.Data.Map
+    ( Map
+
+    , Null
+    , Size
+    , Lookup
+    , LookupAssoc
+    , Member
+    , NotMember
+    , Find
+    , FindWithDefault
+
+    , Empty
+    , Singleton
+
+    , Insert
+    )
+    where
+
+import Types.Data.Bool
+import Types.Data.List hiding (Null)
+import Types.Data.Maybe
+import Types.Data.Num
+import Types.Data.Ord
+
+data Tip
+data Bin size key value left right
+
+class    Map m
+instance Map Tip
+instance Map (Bin s k v l r)
+
+-- Null
+type family   Null m
+type instance Null Tip             = True
+type instance Null (Bin s k v l r) = False
+
+-- Size
+type family   Size m
+type instance Size Tip             = D0
+type instance Size (Bin s k v l r) = s
+
+-- Lookup
+type family   Lookup k m
+type instance Lookup k Tip              = Nothing
+type instance Lookup k (Bin s k' v l r)
+    = If (IsLT (Compare k k'))
+         (Lookup k l)
+         (If (IsGT (Compare k k'))
+             (Lookup k r)
+             (Just v))
+
+-- LookupAssoc
+type family   LookupAssoc k m
+type instance LookupAssoc k Tip              = Nothing
+type instance LookupAssoc k (Bin s k' v l r)
+    = If (IsLT (Compare k k'))
+         (LookupAssoc k l)
+         (If (IsGT (Compare k k'))
+             (LookupAssoc k r)
+             (Just (Cons k v)))
+
+-- Member
+type Member k m = IsJust (Lookup k m)
+
+-- NotMember
+type NotMember k m = Not (Member k m)
+
+-- Find
+type Find k m = FromJust (Lookup k m)
+
+-- FindWithDefault
+type FindWithDefault a k m
+    = FromMaybe a (Lookup k m)
+
+-- Empty
+type Empty = Tip
+
+-- Singleton
+type Singleton k v = Bin D1 k v Tip Tip
+
+-- Insert
+type family   Insert k v m
+type instance Insert k v Tip              = Singleton k v
+type instance Insert k v (Bin s k' v' l r)
+    = If (IsLT (Compare k k'))
+         (Balance k' v' (Insert k v l) r)
+         (If (IsGT (Compare k k'))
+             (Balance k' v' l (Insert k v r))
+             (Bin s k v l r))
+
+-- Balance
+type Delta = D5
+type Ratio = D2
+
+type Balance k v l r
+    = If (Size l :+: Size r :<: 1)
+         (Bin (Size l :+: Size r :+: D1) k v l r)
+         (If (Size r :>=: Delta :*: Size l)
+             (RotateL k v l r)
+             (If (Size l :>=: Delta :*: Size r)
+                 (RotateR k v l r)
+                 (Bin (Size l :+: Size r :+: D1) k v l r)))
+
+-- Rotate
+type family   RotateL k v l r
+type instance RotateL k v l (Bin s k' v' l' r')
+    = If (Size l' :<: Ratio :*: Size r')
+         (SingleL k v l (Bin s k' v' l' r'))
+         (DoubleL k v l (Bin s k' v' l' r'))
+
+type family   RotateR k v l r
+type instance RotateR k v (Bin s k' v' l' r') r
+    = If (Size r' :<: Ratio :*: Size l')
+         (SingleR k v (Bin s k' v' l' r') r)
+         (DoubleR k v (Bin s k' v' l' r') r)
+
+-- Rotations
+type family   SingleL k v l r
+type instance SingleL k v l (Bin s k' v' l' r')
+    = Bin' k' v' (Bin' k v l l') r'
+
+type family   SingleR k v l r
+type instance SingleR k v (Bin s k' v' l r) r'
+    = Bin' k' v' l (Bin' k v r r')
+
+type family   DoubleL k v l r
+type instance DoubleL k v l (Bin s k' v' (Bin s' k'' v'' l' r) r')
+    = Bin' k'' v'' (Bin' k v l l') (Bin' k' v' r r')
+
+type family   DoubleR k v l r
+type instance DoubleR k v (Bin s k' v' l (Bin s' k'' v'' l' r)) r'
+    = Bin' k'' v'' (Bin' k' v' l l') (Bin' k v r r')
+
+-- Bin'
+type Bin' k v l r
+    = Bin (Size l :+: Size r :+: D1) k v l r
+

diff --git a/Types/Data/Maybe.hs b/Types/Data/Maybe.hs
new file mode 100644 (file)
index 0000000..997c93b
--- /dev/null
+++ b/Types/Data/Maybe.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE
+  EmptyDataDecls,
+  TypeFamilies
+  #-}
+module Types.Data.Maybe
+    ( Maybe
+    , Nothing
+    , Just
+
+    , IsNothing
+    , IsJust
+
+    , FromJust
+    , FromMaybe
+    )
+    where
+
+import Prelude ()
+import Types.Data.Bool
+
+
+data Nothing
+data Just a
+
+class    Maybe a
+instance Maybe Nothing
+instance Maybe (Just a)
+
+type family   IsNothing m
+type instance IsNothing Nothing  = True
+type instance IsNothing (Just a) = False
+
+type family   IsJust m
+type instance IsJust Nothing  = False
+type instance IsJust (Just a) = True
+
+type family   FromJust m
+type instance FromJust (Just a) = a
+
+type family   FromMaybe a m
+type instance FromMaybe a Nothing   = a
+type instance FromMaybe a (Just a') = a'

diff --git a/rrdtool.cabal b/rrdtool.cabal
index 655e9a9f98994c299e05b3bb87214aefcb7b3e76..9c0f5241d005c371dd677482396d6ab54f026b1e 100644 (file)
--- a/rrdtool.cabal
+++ b/rrdtool.cabal
@@ -38,6 +38,8 @@ Library
         Data.HList.Graph
         Data.HList.Prelude
         Data.HList.String
+        Types.Data.Map
+        Types.Data.Maybe
 
     GHC-Options:
         -Wall
\ No newline at end of file