{-# LANGUAGE NoMonomorphismRestriction, FlexibleInstances #-}
{-
This file is a slightly modified version of Dr. Kiselyov’s.
You may view Dr. Kiselyov’s original version of this file here:
http://okmij.org/ftp/tagless-final/course/Serialize.hs
* Serialization and de-serialization in tagless-final style
The de-serialization problem is posed in
\url{http://userpages.uni-koblenz.de/~laemmel/TheEagle/}
-}
module SerializeInClass where
import Control.Monad ( liftM, liftM2 )
— Let us recall a basic language with integer literals, negation, and addition…
class ExpSYM repr where
lit :: Int -> repr
neg :: repr -> repr
add :: repr -> repr -> repr
— Recall the basic evaluator
newtype I = I { unI :: Int }
instance ExpSYM I where
lit n = undefined — TODO
neg e = undefined — TODO
add l r = undefined — TODO
eval :: I -> Int
eval = unI
— Recall our string interpreter
newtype S = S { unS :: String }
instance ExpSYM S where
lit n = undefined — TODO
neg e = undefined — TODO
add l r = undefined — TODO
view :: S -> String
view = unS
— A simple example:
tf1 :: ExpSYM repr => repr
tf1 = add (lit 8) (neg (add (lit 1) (lit 2)))
tf1_eval :: Int
tf1_eval = eval tf1
— >>> tf1_eval
tf1_view :: String
tf1_view = view tf1
— >>> tf1_view
— Let’s write a serializer for our expression language using Trees
— Data type of trees representing our expressions `on the wire’
— Our wire format is essentially JSON
data Tree = Leaf String — atom
| Node String [Tree] — collection
deriving (Eq, Read, Show)
— Note that we specifically derive Eq, Read, and Show as the default definition by Haskell is good
newtype T = T { unT :: Tree }
instance ExpSYM T where
lit n = undefined — TODO
neg e = undefined — TODO
add l r = undefined — TODO
toTree :: T -> Tree
toTree = unT
— tf1 = add (lit 8) (neg (add (lit 1) (lit 2)))
tf1_tree :: Tree
tf1_tree = toTree tf1
— >>> tf1_tree
{-
tf1_tree = Node “Add” [Node “Lit” [Leaf “8”],Node “Neg” [Node “Add” [Node “Lit” [Leaf “1”],Node “Lit” [Leaf “2”]]]]
making it a bit more readable…
Node “Add” [
Node “Lit” [Leaf “8”],
Node “Neg” [
Node “Add” [
Node “Lit” [Leaf “1”],
Node “Lit” [Leaf “2”]
]
]
]
… and it looks more like XML/JSON 🙂
-}
— `* //
— The problem is to write a
— * deserializer: take a tree and produce a term
— * Challenge: maintain multiple interpretations
— The result can be interpreted in any existing or future interpreter
— That is a challenging part.
— The deserializer is necessarily a partial function: the input
— may be ill-formed. For example:
— * possible bad input: Node “Lit” [Leaf “1”, Leaf “2”]
— A literal expression may have only one argument.
— We use (Either String a), to model partiality,
— using the String parameter to report errors.` – Dr. Kiselyov
safeRead :: Read a => String -> Either String a
safeRead s = case reads s of
[(x,””)] -> Right x
_ -> Left $ “Read error: ” ++ s
— Let’s define our de-serializer now…
fromTree :: ExpSYM repr => Tree -> Either String repr
fromTree (Node “Lit” [Leaf n]) = undefined — TODO
fromTree (Node “Neg” [e]) = undefined — TODO
fromTree (Node “Add” [l, r]) = undefined — TODO
fromTree e = Left $ “Invalid tree: ” ++ show e
— Nice! Now, let’s try to write a function to evaluate and print the result of expressions de-serialized using fromTree
— ( note the implicit type definition of this function )
printEvalFromTree (Left e) = print $ “Error: ” ++ e
printEvalFromTree (Right expr) = print $ eval expr
— What if we want to print the “view” of this expression?
— ( note the implicit type definition of this function )
printViewFromTree (Left e) = print $ “Error: ” ++ e
printViewFromTree (Right expr) = print $ view expr
— Nice!
— Now, what if we wanted to interpret `expr` multiple times?
— Well, let’s try this out, using implicit type definitions again:
— We’d want something like this…
printBothFromTree (Left e) = print $ “Error: ” ++ e
printBothFromTree (Right expr) = do
print $ eval expr
— print $ view expr — uh oh! We get an error here!
{- But we get an error… expr has been bound to I ???
Serialize.hs:149:18: error:
• Couldn’t match expected type ‘S’ with actual type ‘I’
• In the first argument of ‘view’, namely expr’
In the second argument of ‘($)’, namely ‘view expr’
In a stmt of a ‘do’ block: print $ view expr
|
149 | print $ view expr — uh oh! We get an error here!
| ^
`What happened? We lost polymorphism! The result of fromTree is
polymorphic in the interpreter: ExpSYM repr => repr
After the pattern-matching, the variable x is no longer polymorphic.
Haskell does not have unfettered first-class polymorphism,
for a good reason. Thus after the pattern-match in ‘case’, we can interpret
the result of deserialization only with one interpreter. We have lost
extensibility!` – Dr. Kiselyov
When we case on the Either, the `expr` is bound, giving it a specific type.
Hence, we are only able to use 1 single interpreter on it.
-}
— How do we solve this problem of not being able to interpret a de-serialized expression more than once?
— We introduce a somewhat puzzling interpreter
instance (ExpSYM repr, ExpSYM repr’) => ExpSYM (repr, repr’) where
lit x = undefined — TODO
neg (e1, e2) = undefined — TODO
add (e11, e12) (e21, e22) = undefined — TODO
duplicate :: (ExpSYM repr, ExpSYM repr’) => (repr, repr’) -> (repr, repr’)
duplicate = id
— A duplication interpreter!
— However, we note that the resulting polymorphic types are now 2 different types!
— Now we can write our printer that evaluates and views the tree! 🙂
— again, note the implicit type definition
printBothFromTree’ (Left e) = print $ “Error: ” ++ e
printBothFromTree’ (Right x) = do
print $ view x1
print $ eval x2
where (x1, x2) = duplicate x
{-
Here, we duplicate the originally read in tree, giving the duplicate a different polymorphic type.
This way, when we bind the first, we are not interfering with the second, so we are left
with one bounded and the other left polymorphic. Of course, in this example, we bind both.
However, if we wanted to, we could have duplicated it again, and done something else with it.
Exercise:
Try using the above definition to add another evaluation after viewing and evaluating (potentially, toTree).
-}
— Alternatively, a more flexible way to go about this…
— We create a function to check and consume/interpret some de-serialized tree
checkAndConsume f (Left e) = putStrLn $ “Error: ” ++ e
checkAndConsume f (Right x) = f x
— * Whenever we use a value, we have to duplicate it first,
— to leave the other copy for different interpreters
duplicateAndConsume ev x = do
print (ev x1) — print the interpretation of a duplicated version of the expression
return x2
where (x1, x2) = duplicate x
— We write an interpreter that takes an expression, evaluates it, views it, and prints it converted into a tree.
thrice x = duplicateAndConsume eval x >>= duplicateAndConsume view >>= print . toTree
tf1_3 = checkAndConsume thrice (fromTree tf1_tree)
{-
5
“(8 + (-(1 + 2)))”
Node “Add” [Node “Lit” [Leaf “8”],Node “Neg” [Node “Add” [Node “Lit” [Leaf “1”],Node “Lit” [Leaf “2”]]]]
-}
— We still have a problem!
— Our de-serializer is not yet extensible!
— To allow for extensibility, we need to rewrite our `fromTree` using open recursion
fromTreeExt :: ExpSYM repr => (Tree -> Either String repr) -> Tree -> Either String repr
fromTreeExt self (Node “Lit” [Leaf n]) = undefined — TODO
fromTreeExt self (Node “Neg” [e]) = undefined — TODO
fromTreeExt self (Node “Add” [e1, e2]) = undefined — TODO
fromTreeExt self e = Left $ “Invalid tree: ” ++ show e
— we use the fixpoint combinator to `tie up the knot`
fix :: (t -> t) -> t
fix f = f (fix f)
fromTree’ :: ExpSYM repr => Tree -> Either String repr
fromTree’ = fix fromTreeExt
tf1_3′ = checkAndConsume thrice . fromTree’ $ tf1_tree
{-
5
“(8 + (-(1 + 2)))”
Node “Add” [Node “Lit” [Leaf “8”],Node “Neg” [Node “Add” [Node “Lit” [Leaf “1”],Node “Lit” [Leaf “2”]]]]
-}
main = do
print tf1_tree
tf1_3
tf1_3′