{-# LANGUAGE NoMonomorphismRestriction #-}
{-
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/SerializeExt.hs
* Serialization and de-serialization in the tagless-final style
* for the extended data type
The de-serialization problem is posed in
\url{http://userpages.uni-koblenz.de/~laemmel/TheEagle/}
* Solving the expression problem
What is the expression problem (see the slides)
We can:
add new operations on the data type: we have just added
a serializer
Add a new expression form (multiplication)
We now see how we can extend the serializer and de-serializer.
-}
module SerializeExtInClass where
import SerializeInClass (ExpSYM (..), Tree(..), S(..), I(..), T(..))
import qualified SerializeInClass as Ser hiding (main)
import Control.Monad ( liftM2 )
— First, we extend the serializer with multiplication language
class MulSYM repr where
mul :: repr -> repr -> repr
— evaluator
instance MulSYM I where
mul l r = I $ unI l * unI r
— view
instance MulSYM S where
mul l r = S $ “(” ++ unS l ++ “*” ++ unS r ++ “)”
— tree
instance MulSYM T where
mul l r = T $ Node “Mul” [unT l, unT r]
— And the duplicator
instance (MulSYM repr, MulSYM repr’) => MulSYM (repr,repr’) where
mul (e11, e12) (e21, e22) = undefined — TODO
— Now, let’s create a running example (using a hybrid of the languages!)
— (8 + (-(1 * 2))) * 3
tf2 :: (MulSYM repr, ExpSYM repr) => repr
tf2 = mul (add (lit 8) (neg (mul (lit 1) (lit 2)))) (lit 3)
— Evaluation
— >>> Ser.eval tf2
— View
— >>> Ser.view tf2
tf2_tree :: Tree
tf2_tree = Ser.toTree tf2
— >>> tf2_tree
— * //
— Let us now extend the de-serializer
— We merely `add’ one clause to the de-serializer of unextended terms.
— We have not touched the code of the old de-serializer. The file
— Serialize.hs could have been given to us in the compiled form.
— We don’t need the source code for it since we don’t modify it and
— don’t recompile it.
— The inferred signature is exactly as we wish:
— fromTreeExt
— :: (MulSYM repr, ExpSYM repr) =>
— (Tree -> Either Ser.ErrMsg repr) -> Tree -> Either Ser.ErrMsg repr
— This is a different function, from Ser.fromTreeExt
— It relays to the latter for all other nodes
fromTreeExt self (Node “Mul” [e1, e2]) = liftM2 mul (self e1) (self e2)
fromTreeExt self e = Ser.fromTreeExt self e — use the old one for the rest
— * Tie up the knot again
fromTree = Ser.fix fromTreeExt
{-
What happened??
How did this work?
We called Ser.fromTreeExt!
How did deeper embedded terms of MulSYM get handled?”
Thanks to using the fix point, the open recursive function
allows us to give the `fromTreeExt` from Serialize.hs a different
`recursive` function upon which it uses. Despite the fromTreeExt
from Serialize.hs calling itself, we actually give it this one to
call. As such, when recursive calls are made, it goes back to this
definition, from the start, pattern matching starting with “Mul” 🙂
-}
— Now we can see the real benefit of using fix in real programs.
— The fix point combinator is NOT a mere curiosity
— We can de-serialize the unextended terms using the extended
— de-serializer
tf1′ = Ser.checkAndConsume Ser.thrice . fromTree $ Ser.tf1_tree
{- Output:
5
“(8 + (-(1 + 2)))”
Node “Add” [Node “Lit” [Leaf “8”],Node “Neg” [Node “Add” [Node “Lit” [Leaf “1”],Node “Lit” [Leaf “2”]]]]
-}
— We can now de-serialize the extended terms
— And evaluate them in different interpreters
tf2′ = Ser.checkAndConsume Ser.thrice . fromTree $ tf2_tree
{- Output:
18
“((8 + (-(1*2)))*3)”
Node “Mul” [Node “Add” [Node “Lit” [Leaf “8”],Node “Neg” [Node “Mul” [Node “Lit” [Leaf “1”],Node “Lit” [Leaf “2”]]]],Node “Lit” [Leaf “3”]]
-}
main = do
tf1′
tf2′