software stack puzzle

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
{-# LANGUAGE GADTs, KindSignatures, TypeOperators #-}
module Puzzle where

import Data.ByteString (ByteString, singleton)

class Serializable a where
  serialize :: a -> ByteString
  deserialize :: ByteString -> a

data Fun :: * -> * -> * where
  Id   :: Fun a a
  (:.) :: Serializable b => Fun b c -> (a -> b) -> Fun a c

infixl 9 :.

-- Simple conversion
flatten :: Fun a b -> a -> b
flatten Id        = id
flatten (fs :. f) = flatten fs . f



-- Layering example
runLayers :: Serializable a => Int -> Int -> Fun a b -> ByteString -> ByteString
runLayers 0     m     fs        = runLayers' m fs . deserialize
runLayers (n+1) (m+1) (fs :. f) = runLayers n m fs

runLayers' :: Serializable a => Int -> Fun a b -> a -> ByteString
runLayers' 0     _         = serialize
runLayers' (n+1) (fs :. f) = runLayers' n fs . f


data Layer1 = Layer1
data Layer2 = Layer2
data Layer3 = Layer3
data Layer4 = Layer4

softwareStack :: Fun Layer1 Layer4
softwareStack = Id :. (\ Layer3 -> Layer4) :. (\ Layer2 -> Layer3) :. (\ Layer1 -> Layer2)

example1 = runLayers 1 3 softwareStack (singleton 2)  ==  singleton 4
example2 = runLayers 0 2 softwareStack (singleton 1)  ==  singleton 3




-- Boring serialization instances
instance Serializable Layer1 where
  serialize Layer1 = singleton 1
  deserialize bs | bs == singleton 1 = Layer1
instance Serializable Layer2 where
  serialize Layer2 = singleton 2
  deserialize bs | bs == singleton 2 = Layer2
instance Serializable Layer3 where
  serialize Layer3 = singleton 3
  deserialize bs | bs == singleton 3 = Layer3
instance Serializable Layer4 where
  serialize Layer4 = singleton 4
  deserialize bs | bs == singleton 4 = Layer4

If you wanted to use Data.Thrist

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
{-# LANGUAGE GADTs #-}
module Puzzle where

import Data.ByteString (ByteString, singleton)
import Data.Thrist

class Serializable a where
  serialize :: a -> ByteString
  deserialize :: ByteString -> a

-- Functions with serializable results
data Arr a b = Serializable b => F { unF :: a -> b }

-- Composition chains of functions with serializable results
type Fun = Thrist Arr


-- Simple conversion (using foldrThrist for fun)
flatten :: Fun a b -> a -> b
flatten = foldrThrist (\ (F f) fs -> fs . f) id


-- Layering example
runLayers :: Serializable a => Int -> Int -> Fun a b -> ByteString -> ByteString
runLayers 0     m     fs              = runLayers' m fs . deserialize
runLayers (n+1) (m+1) (Cons (F f) fs) = runLayers n m fs

runLayers' :: Serializable a => Int -> Fun a b -> a -> ByteString
runLayers' 0     _               = serialize
runLayers' (n+1) (Cons (F f) fs) = runLayers' n fs . f

cons f fs = Cons (F f) fs

softwareStack :: Fun Layer1 Layer4
softwareStack
 = cons (\ Layer1 -> Layer2)
 $ cons (\ Layer2 -> Layer3)
 $ cons (\ Layer3 -> Layer4)
 $ Nil

example1 = runLayers 1 3 softwareStack (singleton 2)  ==  singleton 4
example2 = runLayers 0 2 softwareStack (singleton 1)  ==  singleton 3



data Layer1 = Layer1
data Layer2 = Layer2
data Layer3 = Layer3
data Layer4 = Layer4


-- Boring serialization instances
instance Serializable Layer1 where
  serialize Layer1 = singleton 1
  deserialize bs | bs == singleton 1 = Layer1
instance Serializable Layer2 where
  serialize Layer2 = singleton 2
  deserialize bs | bs == singleton 2 = Layer2
instance Serializable Layer3 where
  serialize Layer3 = singleton 3
  deserialize bs | bs == singleton 3 = Layer3
instance Serializable Layer4 where
  serialize Layer4 = singleton 4
  deserialize bs | bs == singleton 4 = Layer4

putting the serialization requirement on the first argument

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
{-# LANGUAGE GADTs, KindSignatures, TypeOperators #-}
module Puzzle where

import Data.ByteString (ByteString, singleton)

class Serializable a where
  serialize :: a -> ByteString
  deserialize :: ByteString -> a

data Fun :: * -> * -> * where
  Id   :: Serializable a => Fun a a
  (:.) :: Serializable a => Fun b c -> (a -> b) -> Fun a c

infixl 9 :.

-- Simple conversion
flatten :: Fun a b -> a -> b
flatten Id        = id
flatten (fs :. f) = flatten fs . f

-- Layering example
-- The second case appears redundant, but we must pattern match on the
-- 'Fun' argument to learn which Serialization instance to use.
runLayers :: Int -> Int -> Fun a b -> ByteString -> ByteString
runLayers 0     m     fs@Id       = runLayers' m fs . deserialize
runLayers 0     m     fs@(_ :. _) = runLayers' m fs . deserialize
runLayers (n+1) (m+1) (fs :. f)   = runLayers n m fs

runLayers' :: Int -> Fun a b -> a -> ByteString
runLayers' _     Id        = serialize
runLayers' 0     (_  :. _) = serialize
runLayers' (n+1) (fs :. f) = runLayers' n fs . f


data Layer1 = Layer1
data Layer2 = Layer2
data Layer3 = Layer3
data Layer4 = Layer4

softwareStack :: Fun Layer1 Layer4
softwareStack = Id :. (\ Layer3 -> Layer4) :. (\ Layer2 -> Layer3) :. (\ Layer1 -> Layer2)

example1 = runLayers 1 3 softwareStack (singleton 2)  ==  singleton 4
example2 = runLayers 0 2 softwareStack (singleton 1)  ==  singleton 3




-- Boring serialization instances
instance Serializable Layer1 where
  serialize Layer1 = singleton 1
  deserialize bs | bs == singleton 1 = Layer1
instance Serializable Layer2 where
  serialize Layer2 = singleton 2
  deserialize bs | bs == singleton 2 = Layer2
instance Serializable Layer3 where
  serialize Layer3 = singleton 3
  deserialize bs | bs == singleton 3 = Layer3
instance Serializable Layer4 where
  serialize Layer4 = singleton 4
  deserialize bs | bs == singleton 4 = Layer4