Commit 03bb02c3 authored by Job Cuppen's avatar Job Cuppen

ex 8.2.2

parent 5c8c1de5
......@@ -10,45 +10,25 @@ module serialize8Start
Use Basic Values Only as conclose option for a nicer output.
*/
import StdEnv, StdMaybe, StdDebug
import StdEnv, StdMaybe
import StdGeneric
generic isUnit a :: a -> Bool
isUnit{|UNIT|} a = True
isUnit{|c|} a = False
//derive isUnit [], Coin, (,), Bin
// use this as serialize0 for kind *
//class serialize a | isUnit a where
// write :: a [String] -> [String]
// read :: [String] -> Maybe (a,[String])
generic write a :: a [String] -> [String]
generic read a :: [String] -> Maybe (a,[String])
class serialize a | read{|*|}, write{|*|}, isUnit{|*|} a
//write :: a [String] -> [String]
//write a c = write{|*|} a
//instance serialize Bool where
write{|Bool|} b c = [toString b:c]
write{|Int|} b c = [toString b:c]
write{|UNIT|} b c = c
write{|PAIR|} f g (PAIR a b) c = f a (g b c)
write{|EITHER|} f g (LEFT a) c = f a c
write{|EITHER|} f g (RIGHT b) c = g b c
write{|CONS of x|} f (CONS a) c = ["(":(trace x.gcd_type_def.gtd_name x.gcd_name):(f a [")":c])]
//write{|FIELD|} f b c = []
write{|OBJECT|} f (OBJECT o) c = f o c
write{|(,)|} f g (a,b) c = ["(":(f a [ ",":(g b [")":c])])]
// Don't flip left and right though, that makes reading using the 'unit without parentheses' not work
class serialize a | read{|*|}, write{|*|} a
write{|Bool|} b c = [toString b:c]
write{|Int|} b c = [toString b:c]
write{|UNIT|} _ c = c
write{|PAIR|} f g (PAIR a b) c = f a (g b c)
write{|EITHER|} f _ (LEFT a) c = f a c
write{|EITHER|} _ g (RIGHT b) c = g b c
write{|CONS of x|} f (CONS a) c
| (x.gcd_arity == 0) = [x.gcd_name:(f a c)]
= ["(":x.gcd_name:(f a [")":c])]
write{|OBJECT|} f (OBJECT o) c = f o c
write{|(,)|} f g (a,b) c = ["(":(f a [ ",":(g b [")":c])])]
read{|Int|} r = foldl (match r) Nothing [True, False]
......@@ -67,236 +47,53 @@ read{|Bool|} r = foldl (match r) Nothing [True, False]
= r
match _ r bool = r
read{|UNIT|} r = Just (UNIT,r)
read{|UNIT|} r = Just (UNIT,r)
read{|PAIR|} f g r = case f r of
Nothing -> Nothing
Just (a,r) -> case g r of
Nothing -> Nothing
Just (b,r) -> Just (PAIR a b, r)
Just (a,r) -> case g r of
Just (b,r) -> Just (PAIR a b, r)
Nothing -> Nothing
Nothing -> Nothing
read{|EITHER|} f g r = case f r of // try to parse the left side...
Just (a,r) -> Just (LEFT a ,r)
Nothing -> case g r of // if that fails, try to parse the right side
Just (a,r) -> Just (RIGHT a ,r)
Nothing -> Nothing
Just (a,r) -> Just (LEFT a ,r)
Nothing -> case g r of // if that fails, try to parse the right side
Just (a,r) -> Just (RIGHT a ,r)
Nothing -> Nothing
read{|CONS|} f ["(":s:r] = case f r of
Just (a,[")":r]) -> Just(CONS a, r)
_ -> Nothing
read{|CONS|} f [s:r] = case f r of
Just (a,r) -> Just(CONS a, r)
_ -> Nothing
read{|CONS of {gcd_name}|} f [s:r]
| s == gcd_name = case f r of
Just (a,r) -> Just(CONS a, r)
Nothing -> Nothing
| otherwise = Nothing
read{|CONS|} f _ = Nothing
//read{|FIELD|} f r = Nothing
read{|OBJECT|} f r = case f r of
Just(a,r) -> Just(OBJECT a, r)
_ -> Nothing
Just(a,r) -> Just(OBJECT a, r)
Nothing -> Nothing
read{|(,)|} f g ["(":r] = case f r of
Just (a,[",":r]) -> case g r of
Just(b,[")":r]) -> Just ((a,b),r)
_ -> Nothing
_ -> Nothing
Just (a,[",":r]) -> case g r of
Just(b,[")":r]) -> Just ((a,b),r)
Nothing -> Nothing
Nothing -> Nothing
derive write [], Bin, Coin
derive read [], Bin, Coin
//write{|*|} b c = []
//read{|*|} r = Nothing
//instance where
// write{|*|} a [String] -> [String]
// read{|*|} [String] -> Maybe (a,[String])
// ---
//derive serialize Bool
/*instance serialize Bool where
write b c = write{|*|} b c
read r = read{|*|} r
*/
/*instance serialize Bool where
write b c = [toString b:c]
read list = foldl (match list) Nothing [True, False]
where
match [string: rest] r bool | toString bool == string
= Just (bool, rest)
= r
match _ r bool = r
instance serialize Int where
write i c = [toString i:c]
read list = foldl (match list) Nothing [True, False]
where
match [string: rest] r bool
# int = toInt string
| string == toString int
= Just (int, rest)
= r
match _ r bool = r
*/
// ---
//:: UNIT = UNIT
//:: EITHER a b = LEFT a | RIGHT b
//:: PAIR a b = PAIR a b
//:: CONS a = CONS String a
// ---
/*
class isUnit a where
isUnit :: a -> Bool
instance isUnit UNIT where
isUnit a = True
instance isUnit a where
isUnit a = False
instance serialize UNIT where
write u c = c
read r = Just (UNIT,r)
instance serialize (PAIR a b) | serialize a & serialize b where
write (PAIR a b) c = (write a (write b c))
read r = case read r of
Nothing -> Nothing
Just (a,r) -> case read r of
Nothing -> Nothing
Just (b,r) -> Just (PAIR a b, r)
instance serialize (EITHER a b) | serialize a & serialize b where
write (LEFT a) c = write a c
write (RIGHT b) c = write b c
read r = case read r of // try to parse the left side...
Just (a,r) -> Just (LEFT a ,r)
Nothing -> case read r of // if that fails, try to parse the right side
Just (a,r) -> Just (RIGHT a ,r)
Nothing -> Nothing
// Don't flip left and right though, that makes reading using the 'unit without parentheses' not work
instance serialize (CONS a) | serialize a where
// Cheekily using the fact that a written unit is an empty list
//write (CONS s a) c = let written = write a [] in
// if (length (written) == 0)
// [s: written++c] // unit without parentheses
// ["(":s: (written ++ [")":c])] // else with parentheses
write (CONS a) c = if (isUnit a)
(write a c) // unit without parentheses
["(": (write a [")":c])] // else with parentheses
read ["(":s:r] = case read r of
Just (a,[")":r]) -> Just(CONS a, r)
_ -> Nothing
read [s:r] = case read r of
Just (a,r) -> Just (CONS a, r)
Nothing -> Nothing
read _ = Nothing
*/
// ------------
:: ListG a :== EITHER (CONS UNIT) (CONS (PAIR a [a]))
fromList :: [a] -> ListG a
fromList [] = LEFT (CONS /*NilString*/ UNIT)
fromList [a:x] = RIGHT (CONS /*ConsString*/ (PAIR a x))
toList :: (ListG a) -> [a]
toList (LEFT (CONS /*NilString*/ UNIT)) = []
toList (RIGHT (CONS /*ConsString*/ (PAIR a x))) = [a:x]
NilString :== "Nil"
ConsString :== "Cons"
/*
instance serialize [a] | serialize a where // to be improved
write a s = s
read s = Nothing
*/
// ---
:: Bin a = Leaf | Bin (Bin a) a (Bin a)
:: BinG a :== EITHER (CONS UNIT) (CONS (PAIR (Bin a) (PAIR a (Bin a))))
fromBin :: (Bin a) -> BinG a
fromBin Leaf = LEFT (CONS /*LeafString*/ UNIT)
fromBin (Bin l a r) = RIGHT (CONS /*BinString*/ (PAIR l (PAIR a r)))
toBin :: (BinG a) -> Bin a
toBin (LEFT (CONS UNIT)) = Leaf
toBin (RIGHT (CONS (PAIR l (PAIR a r)))) = Bin l a r
LeafString :== "Leaf"
BinString :== "Bin"
instance == (Bin a) | == a where
(==) Leaf Leaf = True
(==) (Bin l a r) (Bin k b s) = l == k && a == b && r == s
(==) _ _ = False
/*
instance serialize (Bin a) | serialize a where // to be improved
write b s = s
read l = Nothing
*/
// ---
:: Coin = Head | Tail
:: CoinG :== EITHER (CONS UNIT) (CONS UNIT)
fromCoin :: Coin -> CoinG
fromCoin Head = LEFT (CONS UNIT)
fromCoin Tail = RIGHT (CONS UNIT)
toCoin :: CoinG -> Coin
toCoin (LEFT (CONS UNIT)) = Head
toCoin (RIGHT (CONS UNIT)) = Tail
instance == Coin where
(==) Head Head = True
(==) Tail Tail = True
(==) _ _ = False
/*
instance serialize Coin where
write c s = s
read l = Nothing
*/
/*
Define a special purpose version for this type that writes and reads
the value (7,True) as ["(","7",",","True",")"]
*/
:: TupleG a b :== CONS (PAIR a b)
fromTup :: (a,b) -> (TupleG a b)
fromTup (a,b) = CONS (PAIR a b)
toTup :: (TupleG a b) -> (a,b)
toTup (CONS (PAIR a b)) = (a,b)
/*
instance serialize (a,b) | serialize a & serialize b where
write (a,b) c = ["(":(write a [ ",":(write b [")":c])])] //write (fromTup (a,b)) c
read ["(":r] = case read r of
Just (a,[",":r]) -> case read r of
Just(b,[")":r]) -> Just ((a,b),r)
_ -> Nothing
_ -> Nothing
//read _ = Nothing
*/
// ---
/*
Start =
[test True
]
*/
// output looks nice if compiled with "Basic Values Only" for console in project options
Start =
......@@ -320,7 +117,6 @@ Start =
,["End of the tests.\n"]
]
test :: a -> [String] | serialize, == a
test a =
(if (isJust r)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment