Haskell Quiz/Bytecode Compiler/Solution Lennart Kolmodin

module Main where
 
import Foreign
import Control.Monad
import Data.Bits
import System.Random
import Test.QuickCheck hiding (evaluate)
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Expr
 
-- Main -------------------------------------------------------------
 
main :: IO ()
main = do
    raw <- getContents
    case parse expr "stdin" raw of
        Left err -> print err
        Right e -> do
            let bytecode = compile e
                (interpretion:_) = interpret bytecode
            print e
            print bytecode
            print $ head (interpret bytecode)
            print (evaluate e)
 
-- Data Structs -----------------------------------------------------
 
data Expr = Op BinOp Expr Expr
          | Const Int
          deriving (Show,Eq)
 
data BinOp = Add
           | Sub
           | Mul
           | Div
           | Pow
           | Mod
           deriving (Show,Eq)
 
-- Parsing using Parsec ---------------------------------------------
 
expr    :: Parser Expr
expr    = buildExpressionParser table factor
          <?> "expression"
 
table   = [[op "**" (Op Pow) AssocRight, op "%" (Op Mod) AssocLeft]
          ,[op "*"  (Op Mul) AssocLeft, op "/" (Op Div) AssocLeft]
          ,[op "+"  (Op Add) AssocLeft, op "-" (Op Sub) AssocLeft]
          ] 
        where
          op s f assoc = Infix (do{ try (string s); return f}) assoc
 
factor  = between (char '(') (char ')') expr
        <|> number
        <?> "simple expression"
 
number  :: Parser Expr
number  = liftM (Const . read) (many1 digit)
        <?> "number"
 
-- Compiler ---------------------------------------------------------
 
compile :: Expr -> [Word8]
compile e = compile' e []
 
constInstr = 0x01
lconstInstr = 0x02
addInstr = 0x0a
subInstr = 0x0b
mulInstr = 0x0c
powInstr = 0x0d
divInstr = 0x0e
modInstr = 0x0f
swapInstr = 0xa0
 
w  n = \c -> n : c
w2 n = w (getByte n 1) . w (getByte n 0)
w4 n = w (getByte n 3) . w (getByte n 2) . w (getByte n 1) . w (getByte n 0)
compile' (Const c) | c <= 2^15 = w  constInstr . w2 c
                   | otherwise = w lconstInstr . w4 c
compile' (Op op e1 e2) = compile' e1 . compile' e2 . w opInstr
    where
        opInstr = case op of
                    Add -> addInstr
                    Sub -> subInstr
                    Mul -> mulInstr
                    Div -> divInstr
                    Pow -> powInstr
                    Mod -> modInstr
 
getByte v i = fromIntegral $ (v `shiftR` (i*8)) .&. 0xff 
 
-- Interpreter ------------------------------------------------------
 
interpret :: [Word8] -> [Integer]
interpret instrs = interpret' instrs []
 
interpret' [] st = reverse st 
interpret' (0x01:a:b:rest) st = interpret' rest $
    ((toInteger a `shift` 8) .|. 
     (toInteger b)):st
interpret' (0x02:a:b:c:d:rest) st = interpret' rest $
    ((toInteger a `shift` 24) .|.
     (toInteger b `shift` 16) .|.
     (toInteger c `shift` 8) .|.
     (toInteger d)) : st
interpret' (0xa0:rest) (b:a:st) = interpret' rest (a:b:st)
interpret' (op:rest) (b:a:st) = interpret' rest (f a b:st)
    where f = case () of
                _ | op == addInstr -> (+)
                  | op == subInstr -> (-)
                  | op == mulInstr -> (*)
                  | op == powInstr -> (^)
                  | op == divInstr -> div
                  | op == modInstr -> mod
 
-- Evaluator --------------------------------------------------------
 
evaluate :: Expr -> Integer
evaluate (Const e) = toInteger e
evaluate (Op op e1 e2) = evaluate e1 `f` evaluate e2
    where f = case op of
                Add -> (+)
                Sub -> (-)
                Mul -> (*)
                Div -> div
                Pow -> (^)
                Mod -> mod
 
-- QuickCheck -------------------------------------------------------
 
instance Arbitrary Expr where
    arbitrary = sized $ \n -> sizedExpr n
      where
      sizedExpr n = frequency
          [ (2, genConst)
          , (1, genOp n)
          ]
      genConst = do
          range <- elements [(0,2^15), (2^15,2^32)]
          liftM Const $ choose range
      genOp n | n <= 0 = genConst
              | otherwise = do
          op <- arbitrary
          let n' = (n-1) `div` 4
              subtree = sizedExpr n'
          liftM2 (Op op) subtree subtree
    coarbitrary (Const n) = variant 0 . coarbitrary n
    coarbitrary (Op op e1 e2) = variant 1 . coarbitrary op . coarbitrary e1 . coarbitrary e2
 
instance Arbitrary BinOp where
    arbitrary = elements [Add, Sub, Mul, Div, Pow, Mod]
    coarbitrary op = variant 0 . coarbitrary op
 
depth (Const _) = 1
depth (Op _ e1 e2) = 1 + max (depth e1) (depth e2)
 
prop_id e =
    collect (depth e) $
    trivial (depth e == 1) $ 
    head (interpret . compile $ e) == evaluate e