Personal tools

Haskell Quiz/Bytecode Compiler/Solution Lennart Kolmodin

From HaskellWiki

< Haskell Quiz | Bytecode Compiler(Difference between revisions)
Jump to: navigation, search
(Initial page)
 
(+cat)
 
(2 intermediate revisions by 2 users not shown)
Line 1: Line 1:
Complete solution with parser (cheating using Parsec), compiler, interpreter evaluator and QuickCheck properties.
+
[[Category:Haskell Quiz solutions|Bytecode Compiler]]
  +
Complete solution with parser (cheating using Parsec), compiler, interpreter, evaluator and QuickCheck properties.
   
 
The Arbitrary monad doesn't work properly though, it generates too small or far too large trees.
 
The Arbitrary monad doesn't work properly though, it generates too small or far too large trees.
Line 49: Line 49:
 
<?> "expression"
 
<?> "expression"
   
table = [[op "**" (Op Pow) AssocLeft, op "%" (Op Mod) AssocLeft]
+
table = [[op "**" (Op Pow) AssocRight, op "%" (Op Mod) AssocLeft]
 
,[op "*" (Op Mul) AssocLeft, op "/" (Op Div) AssocLeft]
 
,[op "*" (Op Mul) AssocLeft, op "/" (Op Div) AssocLeft]
 
,[op "+" (Op Add) AssocLeft, op "-" (Op Sub) AssocLeft]
 
,[op "+" (Op Add) AssocLeft, op "-" (Op Sub) AssocLeft]

Latest revision as of 11:09, 13 January 2007

Complete solution with parser (cheating using Parsec), compiler, interpreter, evaluator and QuickCheck properties.

The Arbitrary monad doesn't work properly though, it generates too small or far too large trees.

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