-- * Essentially, Haskell98
{-# LANGUAGE NoMonomorphismRestriction, FlexibleInstances #-}
-- * Serialization and de-serialization in tagless-final style
-- The deserialization problem is posed in
-- \url{http://userpages.uni-koblenz.de/~laemmel/TheEagle/}
module Serialize where
import Intro2 hiding (main)
import Control.Monad
-- Data type of trees representing our expressions `on the wire'
-- Our wire format is essentially JASON
data Tree = Leaf String -- atom
| Node String [Tree] -- collection
deriving (Eq, Read, Show)
-- Serializer for Exp -- just another interpreter, similar
-- to the ones we have seen
instance ExpSYM Tree where
lit n = Node "Lit" [Leaf $ show n]
neg e = Node "Neg" [e]
add e1 e2 = Node "Add" [e1,e2]
toTree :: Tree -> Tree
toTree = id
-- tf1 = add (lit 8) (neg (add (lit 1) (lit 2)))
-- Our sample term
tf1_tree = toTree tf1
-- Looks like a XML/JSON/S-expression...
-- Node "Add" [Node "Lit" [Leaf "8"],
-- Node "Neg" [Node "Add" [Node "Lit" [Leaf "1"],Node "Lit" [Leaf "2"]]]]
-- * //
-- 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 ErrMsg a), the Error monad, to model partiality,
-- reporting error messages.
type ErrMsg = String
safeRead :: Read a => String -> Either ErrMsg a
safeRead s = case reads s of
[(x,"")] -> Right x
_ -> Left $ "Read error: " ++ s
-- * //
-- Inferred type:
-- fromTree :: (ExpSYM b) => Tree -> Either ErrMsg b
fromTree (Node "Lit" [Leaf n]) = liftM lit $ safeRead n
fromTree (Node "Neg" [e]) = liftM neg $ fromTree e
fromTree (Node "Add" [e1,e2]) = liftM2 add (fromTree e1) (fromTree e2)
fromTree e = Left $ "Invalid tree: " ++ show e
-- We can deserialize our sample term and evaluate it
-- with any of the existing interpreters
tf1'_eval =
let tf1' = fromTree tf1_tree
in case tf1' of
Left e -> putStrLn $ "Error: " ++ e
Right x -> print $ eval x
-- 5
-- But we wish to evaluate the de-serialized term several times,
-- with different interpreters
{-
tf1'_evew' =
let tf1' = fromTree tf1_tree
in case tf1' of
Left e -> putStrLn $ "Error: " ++ e
Right x -> do
print $ eval x
print $ view x
And here we get the type error:
Couldn't match expected type `String' against inferred type `Int'
In the first argument of `view', namely `x'
In the second argument of `($)', namely `view x'
In the expression: print $ view x
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!
-}
-- * What are the solutions?
-- One is to re-write fromTree to have this signature
-- * fromTree :: String -> Either ErrMsg Wrapped
-- where
-- * newtype Wrapped = Wrapped{unWrap :: forall repr. ExpSYM repr => repr}
-- emulating first-class polymorphism. The successful case analysis
-- of the parsing result will give us the value of the type Wrapped,
-- which can be interpreted in many ways, as its type indicates.
-- Alas, we lose extensibility again: we can no longer enrich our
-- language because we fixed the constraint ExpSYM. When we later
-- add the multiplication form, we need to add the MulSYM constraint.
-- Thus we have to re-define Wrapped. We could not use any of the
-- existing fromTree code (in its compiled form).
-- Here we show a different solution
-- We introduce a somewhat puzzling interpreter
instance (ExpSYM repr, ExpSYM repr') => ExpSYM (repr,repr') where
lit x = (lit x, lit x)
neg (e1,e2) = (neg e1, neg e2)
add (e11,e12) (e21, e22) = (add e11 e21, add e12 e22)
duplicate :: (ExpSYM repr, ExpSYM repr') => (repr,repr') -> (repr,repr')
duplicate = id
-- * We check the result of deserialization once
-- On success, we pass the deserialized term to a consumer f
check_consume f (Left e) = putStrLn $ "Error: " ++ e
check_consume f (Right x) = f x
-- * Whenever we use a value, we have to duplicate it first,
-- to leave the other copy for different interpreters
dup_consume ev x = print (ev x1) >> return x2
where (x1,x2) = duplicate x
-- We consume the deserialized value with three different interpreters
tf1'_int3 = check_consume thrice . fromTree $ tf1_tree
thrice x = dup_consume eval x >>= dup_consume view >>= print . toTree
{-
5
"(8 + (-(1 + 2)))"
Node "Add" ...
-}
-- * //
-- Let us write the deserializer in the style of open recursion
-- we shall see the benefit later
-- The signature could have been inferred
fromTreeExt :: (ExpSYM repr) =>
(Tree -> Either ErrMsg repr) -> Tree -> Either ErrMsg repr
fromTreeExt self (Node "Lit" [Leaf n]) = liftM lit $ safeRead n
fromTreeExt self (Node "Neg" [e]) = liftM neg $ self e
fromTreeExt self (Node "Add" [e1,e2]) = liftM2 add (self e1) (self e2)
fromTreeExt self e = Left $ "Invalid tree: " ++ show e
-- we use the fixpoint combinator to tie up the knot
fix f = f (fix f)
fromTree' = fix fromTreeExt -- One does use fix in real programs
tf1E_int3 = check_consume thrice . fromTree' $ tf1_tree
{-
5
"(8 + (-(1 + 2)))"
Node "Add" ...
-}
-- * Does each evaluation of tf1' re-parses tf1_tree?
-- We try on a bad input
tfxE_int3 = check_consume thrice . fromTree' $ Node "Lit" [Leaf "1", Leaf "2"]
{-
Error: Invalid tree: Node "Lit" [Leaf "1",Leaf "2"]
-}
-- That is, we get and report the parsing error before we started any
-- interpretation. This implies that the whole parsing is completed
-- before any interpretation starts.
main = do
print tf1_tree
tf1'_eval
tf1'_int3
tf1E_int3
tfxE_int3
-- LocalWords: deserialization Serializer deserializer