Kirjan esimerkkikääntäjä

{-#OPTIONS_GHC -Wall#-}
module Main where
import Prelude hiding (lex)
import Data.Char
import Test.QuickCheck

-- LEXER

data Op     = Plus | Mul
    deriving (Eq,Ord,Show)

data Lexeme = Digit Int |  OpenParen |  CloseParen | Operator Op
    deriving (Eq,Ord,Show)

lex :: String -> [Lexeme]
lex []           = []
lex ('(' : rest) = OpenParen : lex rest
lex (')' : rest) = CloseParen : lex rest
lex (n : rest) | isDigit n     = Digit (read [n]) : lex rest
               | n == '+'      = Operator Plus : lex rest
               | n == '*'      = Operator Mul : lex rest
               | isSeparator n = lex rest
               | n == '\n'     = lex rest
               | otherwise     = error $ "Lexer error at char: " ++ show n

-- PARSER

data AST = Number Int
         | Infix AST Op AST
         deriving Show

parse :: [Lexeme] -> (AST, [Lexeme])
parse []               = error "Expected more input"
parse (Digit n : rest) = (Number n, rest)
parse (OpenParen : rest) =
  let parseOp (Operator o : r) = (o, r)
      parseOp _                = error "Expected an operator"
      parseClose (CloseParen : r) = r
      parseClose (other      : _) = error ("Expected ')', got " ++ show other)
      parseClose []               = error "Unexpected EOF"
      (left , rest2) = parse rest
      (op   , rest3) = parseOp rest2
      (right, rest4) = parse rest3
      rest5          = parseClose rest4
  in  (Infix left op right, rest5)
parse (other : _) = error ("Expected a digit or an '(', got" ++ show other)

parseOnly :: [Lexeme] -> AST
parseOnly s = case parse s of
  (ast, []   ) -> ast
  (_  , stuff) -> error ("Got extra stuff at the end: " ++ show stuff)

-- CODE GENERATOR

data ASM = PUSH Int | ADD | MULT | PRINT deriving (Eq,Show)

codeGen :: AST -> [ASM]
codeGen a = case a of
  Number d           -> [PUSH d]
  Infix left o right -> codeGen left ++ codeGen right ++ genOp o
 where
  genOp Plus = [ADD]
  genOp Mul  = [MULT]

-- INTERPRETERS

interpret :: AST -> Int
interpret a = case a of
  Number n              -> n
  Infix left Plus right -> interpret left + interpret right
  Infix left Mul  right -> interpret left * interpret right

interpretASM :: [Int] -> [String] -> [ASM] -> (Int, [String])
interpretASM (x : _) out [] = (x, out)
interpretASM [] _ [] = error "Program produced no output"
interpretASM stack out (instr : remainder) = case instr of
  PUSH i -> interpretASM (i : stack) out remainder
  ADD    -> case stack of
    (x : y : rest) -> interpretASM (x + y : rest) out remainder
    _              -> error "Stack underflow!"
  MULT -> case stack of
    (x : y : rest) -> interpretASM (x * y : rest) out remainder
    _              -> error "Stack underflow!"
  PRINT -> case stack of
    (x : xs) -> interpretASM (x : xs) (show x : out) remainder
    _        -> error "Stack underflow!"

-- TESTING

instance Arbitrary Op where
    arbitrary = oneof [pure Mul, pure Plus]
instance Arbitrary AST where
    arbitrary =
     sized $ \n -> if n == 0
        then Number <$> arbitrary
        else oneof [Number <$> arbitrary
                   ,resize (n-1)
                        (Infix <$> arbitrary <*> arbitrary <*> arbitrary)]

essential :: AST -> Bool
essential ast = (fst . interpretASM [] [] . codeGen) ast == interpret ast

-- MAIN

main :: IO ()
main = do
  input <- getContents
  let ast = parseOnly (lex input)
      asm = (++ [PRINT]) (codeGen ast)
  putStrLn "CODE:"
  mapM_ print (asm)
  putStrLn "Result:"
  let (_, out) = interpretASM [] [] asm
  mapM_ putStrLn out