From 66d175582375d19adfa8747c9e1c468138d47583 Mon Sep 17 00:00:00 2001 From: PHO Date: Mon, 26 Apr 2010 02:15:58 +0900 Subject: [PATCH] type-level maps and maybes --- Data/HList/Graph.hs | 33 +++++++--- Data/HList/Prelude.hs | 10 +++ Types/Data/Map.hs | 144 ++++++++++++++++++++++++++++++++++++++++++ Types/Data/Maybe.hs | 42 ++++++++++++ rrdtool.cabal | 2 + 5 files changed, 221 insertions(+), 10 deletions(-) create mode 100644 Types/Data/Map.hs create mode 100644 Types/Data/Maybe.hs diff --git a/Data/HList/Graph.hs b/Data/HList/Graph.hs index 7a833ea..c3fcf87 100644 --- 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 3a46616..d50ad25 100644 --- 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 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 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 655e9a9..9c0f524 100644 --- 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 -- 2.40.0