Difference between revisions of "Haskell Quiz/Bytecode Compiler/Solution Michael Sloan"

From HaskellWiki
Jump to navigation Jump to search
 
(sharpen cat)
 
(8 intermediate revisions by one other user not shown)
Line 1: Line 1:
  +
[[Category:Haskell Quiz solutions|Bytecode Compiler]]
−
<haskell>import Data.Map (Map)
  
−
import qualified Data.Map as Map
  
−
import Data.List (intersect)
  
−
import Maybe
  
−
import Char(digitToInt)
  
   
  +
This implementation's only deficiancy is no handling of the negation operator. Proper handling isn't implemented in the ruby quiz tests/solns, however at least basic negative numbers should be included.
−
data Op = Add | Sub | Mul | Div | Pow | Mod | Psh Int | LPar | RPar
  
−
deriving (Show, Eq)
  
   
  +
<haskell>import Char(digitToInt)
−
instance Ord Op where
  
  +
import Debug.Trace(trace)
−
x <= y = precedence x <= precedence y
 
   
  +
data Tok = C Char
−
precedence (Psh _) = 5
  
  +
| N Int
−
precedence Add = 1
  
  +
| Op Char
−
precedence Sub = 1
  
  +
| App Tok Tok Tok
−
precedence Mul = 2
  
  +
| G {members :: [Tok]}
−
precedence Mod = 2
  
  +
−
precedence Div = 3
  
  +
--Debugging porpoises
−
precedence Pow = 3
  
  +
instance Show Tok where
−
precedence LPar = 4
  
  +
show (C ch) = ch : ""
−
precedence RPar = 4
  
  +
show (N i) = show i
−
opFromChar '+' = Add
  
  +
show (Op ch) = ch : ""
−
opFromChar '-' = Sub
  
  +
show (App a o b) = '(' : (show a) ++ (show o) ++ (show b) ++ ")"
−
opFromChar '*' = Mul
  
  +
show (G xs) = '[' : (concatMap (\x -> show x) xs) ++ "]"
−
opFromChar '/' = Div
  
  +
−
opFromChar '^' = Pow
  
  +
compile = bytes . parse
−
opFromChar '%' = Mod
  
  +
−
opFromChar '(' = LPar
  
  +
parse = stripG . G . foldr ((.) . prec) id "+-*/%^" . pToks . parseNOp . map C
−
opFromChar ')' = RPar
  
  +
−  
  +
parseNOp [] = []
−
leftAssoc Pow = False
  
  +
parseNOp ((N num):(C ch):inp)
−
leftAssoc RPar = False
  
  +
| ch `elem` "0123456789" = parseNOp (N (num * 10 + digitToInt ch) : inp)
−
leftAssoc _ = True
  
  +
parseNOp ((C ch):inp) | ch `elem` "0123456789" = parseNOp (N (digitToInt ch) : inp)
−  
  +
parseNOp ((C ch):inp) | ch `elem` "+-*/^%" = parseNOp (Op ch : inp)
−
parse = infixParse [] []
  
  +
parseNOp ((C ch):inp) | ch `elem` " \t\r\n" = parseNOp inp
−
infixParse o s [] = if (length $ intersect [LPar, RPar] o) > 0 then error "Mismatched parenthesis" else reverse s ++ o
  
  +
parseNOp ((C ch):inp) | ch `elem` "()" = (C ch) : (parseNOp inp)
−
infixParse (RPar:LPar:o) s xs = infixParse o s xs
  
  +
parseNOp ((C ch):inp) = trace ("Skipped char '"++[ch]) (parseNOp inp)
−
infixParse o s (x:xs)
  
  +
parseNOp (x:inp) = x : (parseNOp inp)
−
| x `elem` "+-*/^%)" = if not (null o) && (if leftAssoc op then (<=) else (<)) op (o !! 0) then infixParse (tail o) ((o !! 0):s) (x:xs) else infixParse (op:o) s xs
  
  +
−
| x `elem` "0123456789" = case (if null s then Add else s !! 0) of
  
  +
--Groups an array of tokens if it needs to be
−
(Psh cur) -> infixParse ((Psh $ cur * 10 + digitToInt x) : (tail o)) s xs
  
  +
g (x:xs) | null xs = x
−
_ -> infixParse ((Psh $ digitToInt x):o) s xs
  
  +
g xs = G xs
−
| x == '(' = infixParse (LPar:o) s xs
  
  +
−
| x `elem` " \t\r\n" = infixParse o s xs
  
  +
--Returns parsed tokens/stream remainder
−
where op = opFromChar x
  
  +
pToks = fst . parseG
−  
  +
pRem = snd . parseG
−
getByte v i = (v `div` 2^(i*8)) `mod` 256
 
  +
−
toByteArray x n = map (\i -> getByte x i) [(n-1),(n-2)..0]
  
  +
parseG [] = ([], [])
−  
−
bytecode [] = []
 +
parseG [(G ts)] = (ts, [])
  +
parseG ((C '(') : inp) = (g (pToks inp) : (pToks $ pRem inp), [])
−
bytecode (op:xs) = (case op of Add -> [10]; Mul -> [11]; Pow -> [12]; Div -> [14]; Mod -> [15]; (Psh x) -> if (abs x < 2^15) then (1 : toByteArray x 2) else (2 : toByteArray x 4)) ++ bytecode xs</haskell>
  
  +
parseG ((C ')') : inp) = ([], inp)
  +
parseG (i:inp) = (i : (pToks inp), pRem inp)
  +
  +
aPrec mo a (Op o) b = App (g $ prec mo [a]) (Op o) (g $ prec mo [b])
  +
  +
--Traverses groups, applies operators to their immediate arguments
  +
prec mo [] = []
  +
prec mo (a:(Op o):b:inp) | o == mo = prec mo ((aPrec mo a (Op o) b) : inp)
  +
prec mo ((G xs):inp) = (g $ prec mo xs) : (prec mo inp)
  +
prec mo ((App a o b):inp) = (aPrec mo a o b) : (prec mo inp)
  +
prec mo (x:inp) = x : (prec mo inp)
  +
  +
--Removes any vestigial grouping
  +
stripG (App a o b) = App (stripG a) o (stripG b)
  +
stripG (G (x:xs)) | null xs = stripG x
  +
stripG (G (x:xs)) = error $ "error: " ++ show (x:xs) ++ " <- improper infix nesting here"
  +
stripG x = x
  +
  +
--Converts to a byte format
  +
bytes (C x) = error ("Invalid character: " ++ [x])
  +
bytes (N n) = if abs n < 2^15 then 1 : toBytes 2 n else 2 : toBytes 4 n
  +
bytes (Op ch) = case ch of '+' -> [10]; '-' -> [11]; '*' -> [12]; '^' -> [13]; '/' -> [14]; '%' -> [15]
  +
bytes (App a o b) = (bytes a) ++ (bytes b) ++ (bytes o)
  +
bytes x = error ("Error, invalid: " ++ show x)
  +
  +
toBytes n x = map (\i -> (x `div` 2^(i*8)) `mod` 256 ) [(n-1),(n-2)..0]</haskell>

Latest revision as of 10:43, 13 January 2007


This implementation's only deficiancy is no handling of the negation operator. Proper handling isn't implemented in the ruby quiz tests/solns, however at least basic negative numbers should be included. 

import Char(digitToInt)
import Debug.Trace(trace)

data Tok = C   Char
         | N   Int
         | Op  Char
         | App Tok Tok Tok
         | G {members :: [Tok]}
 
--Debugging porpoises
instance Show Tok where
    show (C ch) = ch : ""
    show (N i) = show i
    show (Op ch) = ch : ""
    show (App a o b) = '(' : (show a) ++ (show o) ++ (show b) ++ ")"
    show (G xs) = '[' : (concatMap (\x -> show x) xs) ++ "]"
 
compile = bytes . parse
 
parse = stripG . G . foldr ((.) . prec) id "+-*/%^" . pToks . parseNOp . map C
 
parseNOp [] = []
parseNOp ((N num):(C ch):inp)
                      | ch `elem` "0123456789" = parseNOp (N (num * 10 + digitToInt ch) : inp)
parseNOp ((C ch):inp) | ch `elem` "0123456789" = parseNOp (N (digitToInt ch) : inp)
parseNOp ((C ch):inp) | ch `elem` "+-*/^%"     = parseNOp (Op ch : inp)
parseNOp ((C ch):inp) | ch `elem` " \t\r\n"    = parseNOp inp
parseNOp ((C ch):inp) | ch `elem` "()"         = (C ch) : (parseNOp inp)
parseNOp ((C ch):inp)                          = trace ("Skipped char '"++[ch]) (parseNOp inp)
parseNOp (x:inp)                               = x : (parseNOp inp)
 
--Groups an array of tokens if it needs to be
g (x:xs) | null xs = x
g xs = G xs
 
--Returns parsed tokens/stream remainder
pToks = fst . parseG
pRem  = snd . parseG
 
parseG []              = ([], [])
parseG [(G ts)]        = (ts, [])
parseG ((C '(') : inp) = (g (pToks inp) : (pToks $ pRem inp), []) 
parseG ((C ')') : inp) = ([], inp)
parseG (i:inp)         = (i : (pToks inp), pRem inp)
 
aPrec mo a (Op o) b = App (g $ prec mo [a]) (Op o) (g $ prec mo [b])
 
--Traverses groups, applies operators to their immediate arguments
prec mo [] = []
prec mo (a:(Op o):b:inp) | o == mo = prec mo ((aPrec mo a (Op o) b) : inp)
prec mo ((G xs):inp)               = (g $ prec mo xs) : (prec mo inp)
prec mo ((App a o b):inp)          = (aPrec mo a o b) : (prec mo inp)
prec mo (x:inp) = x : (prec mo inp)
 
--Removes any vestigial grouping
stripG (App a o b) = App (stripG a) o (stripG b)
stripG (G (x:xs)) | null xs = stripG x
stripG (G (x:xs)) = error $ "error: " ++ show (x:xs) ++ " <- improper infix nesting here"
stripG x = x
 
--Converts to a byte format
bytes (C x) = error ("Invalid character: " ++ [x])
bytes (N n) = if abs n < 2^15 then 1 : toBytes 2 n else 2 : toBytes 4 n
bytes (Op ch) = case ch of '+' -> [10]; '-' -> [11]; '*' -> [12]; '^' -> [13]; '/' -> [14]; '%' -> [15]
bytes (App a o b) = (bytes a) ++ (bytes b) ++ (bytes o)
bytes x = error ("Error, invalid: " ++ show x)
 
toBytes n x = map (\i -> (x `div` 2^(i*8)) `mod` 256 ) [(n-1),(n-2)..0]
Retrieved from "https://wiki.haskell.org/index.php?title=Haskell_Quiz/Bytecode_Compiler/Solution_Michael_Sloan&oldid=10209"