Tagless.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoMonomorphismRestriction #-}

module Tagless
  (
    tf1,
    tfm1,
    viewTf1,
    tf1_tree,
    tf1'',
    fact,
    view',
    eval',
    tfxE,
    tf1E
  ) where

import Control.Monad

-- initial
data Exp = Lit Int
    | Neg Exp
    | Add Exp Exp
    | Mul Exp Exp -- added later
         deriving (Show)

ti1' = Add (Lit 8) (Neg (Add (Lit 1) (Lit 2)))

-- the evaluator interpreter
eval :: Exp -> Int
eval (Lit n) = n
eval (Neg e) = - eval e
eval (Add e1 e2) = eval e1 + eval e2

-- ti1 eval to 5

-- another way to embed our language is with functions (final embedding)
type Repr = Int

lit' :: Int -> Repr
lit' n = n

neg' :: Repr -> Repr
neg' e = - e

add' :: Repr -> Repr -> Repr
add' e1 e2 = e1 + e2

tf1' = add' (lit' 8) (neg' (add' (lit' 1) (lit' 2)))

-- pretty-printing interperter with initial
view :: Exp -> String
view (Lit n) = show n
view (Neg e) = "(-" ++ view e ++ ")"
view (Add e1 e2) = "(" ++ view e1 ++ " + " ++ view e2 ++ ")"

-- in the final encoding so far the evaluator is hardwired to tf1

-- the typeclasses for the final encoding
class ExpSYM repr where
  lit :: (Integral a, Show a) => a -> repr
  neg :: repr -> repr
  add :: repr -> repr -> repr

instance ExpSYM String where 
  lit n = show n
  neg e = "(-" ++ e ++ ")"
  add e1 e2 = "(" ++ e1 ++ " + " ++ e2 ++ ")"

instance ExpSYM Int where
  lit n = fromIntegral n
  neg e = - e
  add e1 e2 = e1 + e2

tf1 = add (lit 8) (neg (add (lit 1) (lit 2)))

eval' :: Int -> Int
eval' = id

view' :: String -> String
view' = id

-- collect initial in a list (first class values)
til1 = [Lit 1, Add (Lit 1) (Lit 3)]

{-| final encoding are polymorfic Haskell values (not fully first-class)
storing them in data structures or passing as arguments generally losses polymorfism |-}

tfl1 = [lit 1, add (lit 1) (lit 3)]

-- extending the final encoding is as easy to add a mew typeclass for repr

class MulSYM repr where
  mul :: repr -> repr -> repr

instance MulSYM Int where
  mul e1 e2 = e1 * e2

tfm1 = add (lit 7) (neg (mul (lit 1) (lit 2)))

tfm2 = mul (lit 7) tf1

viewTf1 = view' $ add (lit 8) (neg (add (lit 1) (lit 2))) -- "(8 + (-(1 + 2)))"

-- the de-serialization problem
data Tree = Leaf String
          | Node String [Tree]
            deriving (Eq, Read, Show)

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_tree = toTree $ add (lit 8) (neg (add (lit 1) (lit 2))) -- sample tree

type ErrMsg = String

safeRead :: Read a => String -> Either ErrMsg a
safeRead s = case reads s of
             [(x, "")] -> Right x
             _         -> Left $ "Read error: " ++ s

-- parses a tree into the expression language safely
fromTree :: (ExpSYM repr) => Tree -> Either ErrMsg repr
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

-- can only use one interpreter at the time
tf11 _eval =
      let tf11 = fromTree tf1_tree
      in case tf11 of
         Left e -> putStrLn $ "Error: " ++ e
         Right x -> do
           print $ view' x -- view interperter
           --print $ eval' x

-- instance for duplicating the expression
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

-- pattern match on the result
check_consume f (Left e) = putStrLn $ "Error: " ++ e
check_consume f (Right x) = f x

-- duplicates the polymorfic expression
dup_consume ev x = print (ev x1) >> return x2
       where (x1, x2) = duplicate x
             
thrice x = dup_consume eval' x >>= dup_consume view' >>= print . toTree

-- prints a polymorfic language expression in 3 different ways (two interpreters + the ast tree)
tf1'' = check_consume thrice . fromTree -- tf1'' tf1_tree


-- detour for Y combinator
y f = f (y f)

fact_ fact x = if x == 0 then 1 else (*) x $ fact $ x - 1

fact = y fact_

-- fact 5 // 120 (neat!)

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

fix f = f ( fix f )

fromTree' = fix fromTreeExt

tf1E = check_consume thrice . fromTree' -- tf1E tf1_tree
tfxE = check_consume thrice . fromTree' $ Node "Lit" [Leaf "1", Leaf "2"] -- errors with invalid tree message