From 70b5f2c9d3aa960a90e6456b43e5b0e703848335 Mon Sep 17 00:00:00 2001
From: Camil Staps
Date: Tue, 26 Sep 2017 10:31:00 +0200
Subject: Assignment 3.1

---
 assignment-3/serialize3Start.icl | 108 +++++++++++++++++++++++++++++++++++----
 1 file changed, 98 insertions(+), 10 deletions(-)

(limited to 'assignment-3')

diff --git a/assignment-3/serialize3Start.icl b/assignment-3/serialize3Start.icl
index 11eba33..70b373d 100644
--- a/assignment-3/serialize3Start.icl
+++ b/assignment-3/serialize3Start.icl
@@ -15,10 +15,21 @@ import StdEnv, StdMaybe
 :: Read a  :== [String] -> Maybe (a,[String])
 
 // use this as serialize0 for kind *
-class serialize a where
+class serialize a
+where
 	write :: a [String] -> [String]
 	read  :: [String] -> Maybe (a,[String])
 
+class serialize1 t
+where
+	write1 :: (Write a) (t a) [String] -> [String]
+	read1  :: (Read a) [String] -> Maybe (t a, [String])
+
+class serialize2 t
+where
+	write2 :: (Write a) (Write b) (t a b) [String] -> [String]
+	read2  :: (Read a) (Read b) [String] -> Maybe (t a b, [String])
+
 // ---
 
 instance serialize Bool where
@@ -43,6 +54,51 @@ instance serialize Int where
 :: PAIR   a b = PAIR a b
 :: CONS   a   = CONS String a
 
+instance serialize UNIT
+where
+	write UNIT s = s
+	read l = Just (UNIT, l)
+
+instance serialize2 EITHER
+where
+	write2 f _ (LEFT  x) s = f x s
+	write2 _ g (RIGHT x) s = g x s
+	read2 f g s = case f s of
+		Just (x,s) -> Just (LEFT x,s)
+		Nothing -> case g s of
+			Just (x,s) -> Just (RIGHT x,s)
+			Nothing -> Nothing
+
+instance serialize2 PAIR
+where
+	write2 f g (PAIR x y) s = f x [" ":g y s]
+	read2 f g s = case f s of
+		Just (x,[" ":s]) -> case g s of
+			Just (y,s) -> Just (PAIR x y,s)
+			Nothing -> Nothing
+		_ -> Nothing
+
+instance serialize1 CONS
+where
+	write1 f (CONS c x) s = cleanup ["(":c:" ":f x [")":s]]
+	where
+		// Remove redundant parentheses
+		cleanup :: [String] -> [String]
+		cleanup ["(":c:" ":")":s] = [c:s]
+		cleanup s = s
+	read1 f ["(":c:" ":s] = case f s of
+		Just (x,[")":s]) -> Just (CONS c x,s)
+		_ -> Nothing
+	// Special case for constructors without parentheses. After reading the
+	// argument, we continue with the original stream, because cleanup only
+	// removes parentheses for constructors where the write of the argument did
+	// not write anything. It is probably equivalent to continuing with the new
+	// stream (as the read should not read anything), but this seems safer.
+	read1 f [c:s] = case f s of
+		Just (x,_) -> Just (CONS c x,s)
+		Nothing -> Nothing
+	read1 _ _ = Nothing
+
 // ---
 
 :: ListG a :== EITHER (CONS UNIT) (CONS (PAIR a [a]))
@@ -58,9 +114,12 @@ toList (RIGHT (CONS ConsString (PAIR a x))) = [a:x]
 NilString :== "Nil"
 ConsString :== "Cons"
 
-instance serialize [a] | serialize a where
- write a s = s
- read    s = Nothing
+instance serialize [a] | serialize a
+where
+	write xs s = write2 (write1 write) (write1 (write2 write write)) (fromList xs) s
+	read     s = case read2 (read1 read) (read1 (read2 read read)) s of
+		Just (xs,s) -> Just (toList xs,s)
+		Nothing -> Nothing
 
 // ---
 
@@ -85,8 +144,24 @@ instance == (Bin a) | == a where
 	(==) _ _ = False
 
 instance serialize (Bin a) | serialize a where
-	write b s = s
-	read    l = Nothing
+	write b s = write2 (write1 write) (write1 (write2 write (write2 write write))) (fromBin b) s
+	read    l = case read2 (read1 read) (read1 (read2 read (read2 read read))) l of
+		Just (b,s) -> Just (toBin b,s)
+		Nothing -> Nothing
+
+instance serialize1 Bin
+where
+	write1 _ Leaf s = [LeafString:s]
+	write1 f (Bin l x r) s = ["(":BinString:" ":write1 f l [" ":f x [" ":write1 f r [")":s]]]]
+	read1 _ [LeafString:s] = Just (Leaf,s)
+	read1 f ["(":BinString:" ":s] = case read1 f s of
+		Just (l,[" ":s]) -> case f s of
+			Just (x,[" ":s]) -> case read1 f s of
+				Just (r,[")":s]) -> Just (Bin l x r,s)
+				_ -> Nothing
+			_ -> Nothing
+		_ -> Nothing
+	read1 _ _ = Nothing
 
 // ---
 
@@ -107,16 +182,29 @@ instance == Coin where
 	(==) _    _    = False
 
 instance serialize Coin where
-	write c s = s
-	read    l = Nothing
+	write Head s = ["Head":s]
+	write Tail s = ["Tail":s]
+	read ["Head":l] = Just (Head,l)
+	read ["Tail":l] = Just (Tail,l)
+	read l = Nothing
 
 /*
 	Define a special purpose version for this type that writes and reads
 	the value (7,True) as ["(","7",",","True",")"]
 */
 instance serialize (a,b) | serialize a & serialize b where
-	write (a,b) c = c
-	read _ = Nothing
+	write t c = write2 write write t c
+	read l = read2 read read l
+
+instance serialize2 (,)
+where
+	write2 f g (x,y) s = ["(":f x [",":g y [")":s]]]
+	read2 f g ["(":s] = case f s of
+		Just (x,[",":s]) -> case g s of
+			Just (y,[")":s]) -> Just ((x,y), s)
+			_ -> Nothing
+		_ -> Nothing
+	read2 _ _ _ = Nothing
 
 // ---
 // output looks nice if compiled with "Basic Values Only" for console in project options
-- 
cgit v1.2.3