+module serialize3Start\r
+\r
+/*\r
+ Definitions for assignment 3 in AFP 2018\r
+ Kind indexed gennerics\r
+ Pieter Koopman, pieter@cs.ru.nl\r
+ September 2018\r
+ \r
+ Use StdEnv or iTask environment.\r
+ Use Basic Values Only as conclose option for a nicer output.\r
+*/\r
+\r
+import StdEnv, StdMaybe\r
+\r
+// use this as serialize for kind *\r
+class serialize a where\r
+ write :: a [String] -> [String]\r
+ read :: [String] -> Maybe (a, [String])\r
+\r
+class serialize1 t where\r
+ write1 :: (a [String] -> [String]) (t a) [String] -> [String]\r
+ read1 :: ([String] -> Maybe (a, [String])) [String] -> Maybe (t a, [String])\r
+\r
+class serialize2 t where\r
+ write2 :: (a [String] -> [String]) (b [String] -> [String]) (t a b) [String] -> [String]\r
+ read2 :: ([String] -> Maybe (a, [String])) ([String] -> Maybe (b, [String])) [String] -> Maybe (t a b, [String])\r
+\r
+// ---\r
+\r
+instance serialize Bool where\r
+ write b c = [toString b:c]\r
+ read ["True":c] = Just (True, c)\r
+ read ["False":c] = Just (False, c)\r
+ read _ = Nothing\r
+\r
+instance serialize Int where\r
+ write i c = [toString i:c]\r
+ read [i:c] = Just (toInt i, c)\r
+ read _ = Nothing\r
+\r
+// ---\r
+\r
+:: UNIT = UNIT\r
+:: EITHER a b = LEFT a | RIGHT b\r
+:: PAIR a b = PAIR a b\r
+:: CONS a = CONS String a\r
+\r
+instance serialize UNIT\r
+where\r
+ write UNIT c = c\r
+ read c = Just (UNIT, c)\r
+\r
+instance serialize2 EITHER\r
+where\r
+ write2 wl _ (LEFT a) c = wl a c\r
+ write2 _ wr (RIGHT a) c = wr a c\r
+ read2 rl rr c = case rl c of\r
+ Just (a, c) = Just (LEFT a, c)\r
+ Nothing = case rr c of\r
+ Just (a, c) = Just (RIGHT a, c)\r
+ Nothing = Nothing\r
+\r
+instance serialize2 PAIR\r
+where\r
+ write2 wl wr (PAIR l r) c = wl l (wr r c)\r
+ read2 rl rr c = case rl c of\r
+ Just (a, c) = case rr c of\r
+ Just (b, c) = Just (PAIR a b, c)\r
+ Nothing = Nothing\r
+ Nothing = Nothing\r
+\r
+instance serialize1 CONS\r
+where\r
+ write1 wa (CONS n a) c = ["(",n:wa a [")":c]]\r
+ read1 ra ["(",n:c] = case ra c of\r
+ Just (a, [")":c]) = Just (CONS n a, c)\r
+ _ = Nothing\r
+ read1 _ _ = Nothing\r
+\r
+// ---\r
+\r
+:: ListG a :== EITHER (CONS UNIT) (CONS (PAIR a [a]))\r
+\r
+fromList :: [a] -> ListG a\r
+fromList [] = LEFT (CONS "Nil" UNIT)\r
+fromList [a:x] = RIGHT (CONS "Cons" (PAIR a x))\r
+\r
+toList :: (ListG a) -> [a]\r
+toList (LEFT (CONS "Nil" UNIT)) = []\r
+toList (RIGHT (CONS "Cons" (PAIR a x))) = [a:x]\r
+\r
+instance serialize1 []\r
+where\r
+ write1 wa a c = write2 (write1 write) (write1 (write2 wa (write1 wa))) (fromList a) c\r
+ read1 ra c = case read2 (read1 read) (read1 (read2 ra (read1 ra))) c of\r
+ Just (a, c) = Just (toList a, c)\r
+ Nothing = Nothing\r
+\r
+// ---\r
+\r
+:: Bin a = Leaf | Bin (Bin a) a (Bin a)\r
+\r
+:: BinG a :== EITHER (CONS UNIT) (CONS (PAIR (Bin a) (PAIR a (Bin a))))\r
+\r
+fromBin :: (Bin a) -> BinG a\r
+fromBin Leaf = LEFT (CONS "Leaf" UNIT)\r
+fromBin (Bin l a r) = RIGHT (CONS "Bin" (PAIR l (PAIR a r)))\r
+\r
+toBin :: (BinG a) -> Bin a\r
+toBin (LEFT (CONS _ UNIT)) = Leaf\r
+toBin (RIGHT (CONS _ (PAIR l (PAIR a r)))) = Bin l a r\r
+\r
+instance == (Bin a) | == a where\r
+ (==) Leaf Leaf = True\r
+ (==) (Bin l a r) (Bin k b s) = l == k && a == b && r == s\r
+ (==) _ _ = False\r
+\r
+instance serialize1 Bin\r
+where\r
+ write1 wa a c = write2 (write1 write) (write1 (write2 (write1 wa) (write2 wa (write1 wa)))) (fromBin a) c\r
+ read1 ra c = case read2 (read1 read) (read1 (read2 (read1 ra) (read2 ra (read1 ra)))) c of\r
+ Just (a, c) = Just (toBin a, c)\r
+ Nothing = Nothing\r
+\r
+// ---\r
+\r
+:: Coin = Head | Tail\r
+:: CoinG :== EITHER (CONS UNIT) (CONS UNIT)\r
+\r
+fromCoin :: Coin -> CoinG\r
+fromCoin Head = LEFT (CONS "Head" UNIT)\r
+fromCoin Tail = RIGHT (CONS "Tail" UNIT)\r
+\r
+toCoin :: CoinG -> Coin\r
+toCoin (LEFT (CONS _ UNIT)) = Head\r
+toCoin (RIGHT (CONS _ UNIT)) = Tail\r
+\r
+instance == Coin where\r
+ (==) Head Head = True\r
+ (==) Tail Tail = True\r
+ (==) _ _ = False\r
+\r
+instance serialize Coin where\r
+ write s c = write2 (write1 write) (write1 write) (fromCoin s) c\r
+ read c = case read2 (read1 read) (read1 read) c of\r
+ Just (a, c) = Just (toCoin a, c)\r
+ Nothing = Nothing\r
+\r
+/*\r
+ Define a special purpose version for this type that writes and reads\r
+ the value (7,True) as ["(","7",",","True",")"]\r
+*/\r
+instance serialize2 (,)\r
+where\r
+ write2 wa wb (a, b) c = ["(":wa a [",":wb b [")":c]]]\r
+ read2 ra rb ["(":c] = case ra c of\r
+ Just (a, [",":c]) = case rb c of\r
+ Just (b, [")":c]) = Just ((a, b), c)\r
+ _ = Nothing\r
+ _ = Nothing\r
+ read2 _ _ _ = Nothing\r
+\r
+instance serialize [a] | serialize a\r
+where\r
+ write a c = write1 write a c\r
+ read c = read1 read c\r
+\r
+instance serialize (Bin a) | serialize a\r
+where\r
+ write a c = write1 write a c\r
+ read c = read1 read c\r
+\r
+instance serialize (a, b) | serialize a & serialize b\r
+where\r
+ write a c = write2 write write a c\r
+ read c = read2 read read c\r
+\r
+// ---\r
+// output looks nice if compiled with "Basic Values Only" for console in project options\r
+Start = \r
+ [test True\r
+ ,test False\r
+ ,test 0\r
+ ,test 123\r
+ ,test -36\r
+ ,test [42]\r
+ ,test [0..4]\r
+ ,test [[True],[]]\r
+ ,test [[[1]],[[2],[3,4]],[[]]]\r
+ ,test (Bin Leaf True Leaf)\r
+ ,test [Bin (Bin Leaf [1] Leaf) [2] (Bin Leaf [3] (Bin Leaf [4,5] Leaf))]\r
+ ,test [Bin (Bin Leaf [1] Leaf) [2] (Bin Leaf [3] (Bin (Bin Leaf [4,5] Leaf) [6,7] (Bin Leaf [8,9] Leaf)))]\r
+ ,test Head\r
+ ,test Tail\r
+ ,test (7,True)\r
+ ,test (Head,(7,[Tail]))\r
+ ,["End of the tests.\n"]\r
+ ]\r
+\r
+test :: a -> [String] | serialize, == a\r
+test a = \r
+ (if (isJust r)\r
+ (if (fst jr == a)\r
+ (if (isEmpty (tl (snd jr)))\r
+ ["Oke"]\r
+ ["Not all input is consumed! ":snd jr])\r
+ ["Wrong result: ":write (fst jr) []])\r
+ ["read result is Nothing"]\r
+ ) ++ [", write produces: ": s]\r
+ where\r
+ s = write a ["\n"]\r
+ r = read s\r
+ jr = fromJust r\r