Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Added data descriptor combinators and instances.

  • Loading branch information...
commit 3fafb18d64c5c33a72fed2a618947a5cec8b4f2d 1 parent 15012e5
@luqui authored
View
9 Udon/DataDesc.hs
@@ -1,6 +1,7 @@
module Udon.DataDesc
( ExtRef, extRefHash, unsafeExtRefValue, unsafeMakeExtRef
, DataDesc, ddDump, ddGC, ddRead
+ , Data(..)
, Dump(..)
, GCQueue(..)
, pure, sequ, ref, binary
@@ -31,6 +32,11 @@ data DataDesc a
, ddRead :: Get a
}
+-- This class is to guarantee uniqueness of descriptors
+class Data a where
+ desc :: DataDesc a
+
+
data Dump = Dump Put [(Hash, Dump)]
instance Monoid Dump where
@@ -69,3 +75,6 @@ binary = DataDesc {
ddDump = \a -> Dump (put a) [],
ddGC = \_ -> mempty,
ddRead = get }
+
+instance Data a => Data (ExtRef a) where
+ desc = ref desc
View
7 Udon/Database.hs
@@ -9,13 +9,6 @@ import Udon.Hash
import Udon.DataDesc
import Data.Binary.Put (runPut)
--- This class is to guarantee uniqueness of descriptors
-class Data a where
- desc :: DataDesc a
-
-instance Data a => Data (ExtRef a) where
- desc = ref desc
-
data Database m
-- The weird signature for fetch is an optimization. Sometimes
-- it's easier to tell whether you *can* get a reference than
View
61 Udon/DescCombinators.hs
@@ -0,0 +1,61 @@
+module Udon.DescCombinators where
+
+import Udon.DataDesc
+import Data.Maybe (isJust, listToMaybe)
+import Control.Monad (guard)
+
+unit :: DataDesc ()
+unit = pure ()
+
+pair :: DataDesc a -> DataDesc b -> DataDesc (a,b)
+pair p q = sequ fst p $ \x ->
+ sequ snd q $ \y ->
+ pure (x,y)
+
+wrap :: (a -> b, b -> a) -> DataDesc a -> DataDesc b
+wrap (i,j) p = sequ j p (pure . i)
+
+fixedList :: DataDesc a -> Int -> DataDesc [a]
+fixedList p 0 = pure []
+fixedList p n = wrap consIso (pair p (fixedList p (n-1)))
+ where
+ consIso = (\(a,b) -> a:b, \(a:b) -> (a,b))
+
+list :: DataDesc a -> DataDesc [a]
+list = sequ length binary . fixedList
+
+data Pattern a where
+ Pattern :: (a -> Maybe b) -> DataDesc b -> (b -> a) -> Pattern a
+
+-- The first argument is a notation hack. See descMaybe and descEither for
+-- usage.
+match :: ([a] -> [b]) -> DataDesc b -> (b -> a) -> Pattern a
+match f = Pattern (listToMaybe . f . return)
+
+alt :: forall a. [Pattern a] -> DataDesc a
+alt pats =
+ sequ tag binary $ \idx ->
+ case pats !! idx of
+ Pattern match descb t -> wrap (t, myFromJust . match) descb
+ where
+ tag :: a -> Int
+ tag x = myHead $ do
+ (n, Pattern pat _ _) <- zip [0..] pats
+ guard (isJust (pat x))
+ return n
+
+ myHead [] = error "Non-exhaustive patterns in alternation"
+ myHead (x:xs) = x
+
+ myFromJust Nothing = error "Ack! Data inconsistency!"
+ myFromJust (Just x) = x
+
+descMaybe :: DataDesc a -> DataDesc (Maybe a)
+descMaybe p = alt [
+ match (\x -> [()| Nothing <- x]) unit (const Nothing),
+ match (\x -> [y | Just y <- x]) p Just ]
+
+descEither :: DataDesc a -> DataDesc b -> DataDesc (Either a b)
+descEither p q = alt [
+ match (\x -> [y | Left y <- x]) p Left,
+ match (\x -> [y | Right y <- x]) q Right ]
View
34 Udon/DescInstances.hs
@@ -0,0 +1,34 @@
+module Udon.DescInstances where
+
+import Udon.DataDesc
+import qualified Udon.DescCombinators as D
+import qualified Data.ByteString as Str
+import qualified Data.ByteString.Lazy as StrL
+import Data.Ratio
+import qualified Data.IntSet as IntSet
+import Data.Binary (Binary)
+
+
+-- A bunch of binary instances
+instance Data Bool where desc = binary
+instance Data Char where desc = binary
+instance Data Double where desc = binary
+instance Data Float where desc = binary
+instance Data Int where desc = binary
+instance Data Integer where desc = binary
+instance Data Ordering where desc = binary
+instance Data () where desc = binary
+instance Data Str.ByteString where desc = binary
+instance Data StrL.ByteString where desc = binary
+instance Data IntSet.IntSet where desc = binary
+
+instance (Binary a, Integral a) => Data (Ratio a) where
+ desc = binary
+
+-- Combinatory instances
+instance Data a => Data [a] where desc = D.list desc
+instance Data a => Data (Maybe a) where desc = D.descMaybe desc
+instance (Data a, Data b) => Data (Either a b) where
+ desc = D.descEither desc desc
+instance (Data a, Data b) => Data (a,b) where
+ desc = D.pair desc desc
Please sign in to comment.
Something went wrong with that request. Please try again.