The topic of an extensible, modular interpreter in the tagless final style has come up before. A bit more than a year ago, on a flight from Frankfurt to San Francisco I wrote two interpreters for a trivial subset of Haskell or ML (PCF actually), just big enough for Power, Fibonacci and other classic functions. The following code is a fragment of meta-Haskell. It defines the object language and two interpreters: one is the typed meta-circular interpreter, and the other is a non-too-pretty printer. We can write the expression once:
> power = > fix $ \self -> > lam $ \x -> lam $ \n -> > if_ (n <= 0) 1 > (x * ((self $$ x) $$ (n - 1))) and interpret it several times, as an integer > -- testpw :: Int > testpw = (unR power) (unR 2) ((unR 7)::Int) > -- 128 or as a string > -- testpwc :: P.String > testpwc = showQC power {- "(let self0 = (\\t1 -> (\\t2 -> (if (t2 <= 0) then 1 else (t1 * ((self0 t1) (t2 - 1)))))) in self0)" -} The code follows. It is essentially Haskell98, with the exception of multi-parameter type classes (but no functional dependencies, let alone overlapping instances). {-# LANGUAGE NoMonomorphismRestriction, NoImplicitPrelude #-} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} -- A trivial introduction to `meta-Haskell', just enough to give a taste -- Please see the tests at the end of the file module Intro where import qualified Prelude as P import Prelude (Monad(..), (.), putStrLn, IO, Integer, Int, ($), (++), (=<<), Bool(..)) import Control.Monad (ap) import qualified Control.Monad.State as S -- Definition of our object language -- Unlike that in the tagless final paper, the definition here is spread -- across several type classes for modularity class QNum repr a where (+) :: repr a -> repr a -> repr a (-) :: repr a -> repr a -> repr a (*) :: repr a -> repr a -> repr a negate :: repr a -> repr a fromInteger :: Integer -> repr a infixl 6 +, - infixl 7 * class QBool repr where true, false :: repr Bool if_ :: repr Bool -> repr w -> repr w -> repr w class QBool repr => QLeq repr a where (<=) :: repr a -> repr a -> repr Bool infix 4 <= -- Higher-order fragment of the language class QHO repr where lam :: (repr a -> repr r) -> repr (a -> r) ($$) :: repr (a -> r) -> (repr a -> repr r) fix :: (repr a -> repr a) -> repr a infixr 0 $$ -- The first interpreter R -- which embeds the object language in -- Haskell. It is a meta-circular interpreter, and so is trivial. -- It still could be useful if we wish just to see the result -- of our expressions, quickly newtype R a = R{unR :: a} instance P.Num a => QNum R a where R x + R y = R $ x P.+ y R x - R y = R $ x P.- y R x * R y = R $ x P.* y negate = R . P.negate . unR fromInteger = R . P.fromInteger instance QBool R where true = R True false = R False if_ (R True) x y = x if_ (R False) x y = y instance QLeq R Int where R x <= R y = R $ x P.<= y instance QHO R where lam f = R $ unR . f . R R f $$ R x = R $ f x fix f = f (fix f) -- The second interpreter: pretty-printer -- Actually, it is not pretty, but sufficient newtype S a = S{unS :: S.State Int P.String} instance QNum S a where S x + S y = S $ app_infix "+" x y S x - S y = S $ app_infix "-" x y S x * S y = S $ app_infix "*" x y negate (S x) = S $ (return $ \xc -> "(negate " ++ xc ++ ")") `ap` x fromInteger = S . return . P.show app_infix op x y = do xc <- x yc <- y return $ "(" ++ xc ++ " " ++ op ++ " " ++ yc ++ ")" instance QBool S where true = S $ return "True" false = S $ return "False" if_ (S b) (S x) (S y) = S $ do bc <- b xc <- x yc <- y return $ "(if " ++ bc ++ " then " ++ xc ++ " else " ++ yc ++ ")" instance QLeq S a where S x <= S y = S $ app_infix "<=" x y newName stem = do cnt <- S.get S.put (P.succ cnt) return $ stem ++ P.show cnt instance QHO S where S x $$ S y = S $ app_infix "" x y lam f = S $ do name <- newName "t" let xc = name bc <- unS . f . S $ return xc return $ "(\\" ++ xc ++ " -> " ++ bc ++ ")" fix f = S $ do self <- newName "self" let sc = self bc <- unS . f . S $ return sc return $ "(let " ++ self ++ " = " ++ bc ++ " in " ++ sc ++ ")" showQC :: S a -> P.String showQC (S m) = S.evalState m (unR 0) -- ------------------------------------------------------------------------ -- Tests -- Perhaps the first test should be the power function... -- The following code can be interpreted and compiled just as it is... power = fix $ \self -> lam $ \x -> lam $ \n -> if_ (n <= 0) 1 (x * ((self $$ x) $$ (n - 1))) -- The interpreted result -- testpw :: Int testpw = (unR power) (unR 2) ((unR 7)::Int) -- 128 -- The result of compilation. -- testpwc :: P.String testpwc = showQC power {- "(let self0 = (\\t1 -> (\\t2 -> (if (t2 <= 0) then 1 else (t1 * ((self0 t1) (t2 - 1)))))) in self0)" -} _______________________________________________ Haskell-Cafe mailing list Haskell-Cafe@haskell.org http://www.haskell.org/mailman/listinfo/haskell-cafe