Haskell Quiz/Bytecode Compiler/Solution Michael Sloan
From HaskellWiki
< Haskell Quiz | Bytecode Compiler(Difference between revisions)
(sharpen cat) |
|||
| (2 intermediate revisions not shown.) | |||
| Line 1: | Line 1: | ||
| - | [[Category: | + | [[Category:Haskell Quiz solutions|Bytecode Compiler]] |
| + | |||
| + | 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. | ||
<haskell>import Char(digitToInt) | <haskell>import Char(digitToInt) | ||
| + | import Debug.Trace(trace) | ||
data Tok = C Char | data Tok = C Char | ||
| Line 8: | Line 11: | ||
| App Tok Tok Tok | | App Tok Tok Tok | ||
| G {members :: [Tok]} | | G {members :: [Tok]} | ||
| - | + | ||
--Debugging porpoises | --Debugging porpoises | ||
instance Show Tok where | instance Show Tok where | ||
| Line 16: | Line 19: | ||
show (App a o b) = '(' : (show a) ++ (show o) ++ (show b) ++ ")" | show (App a o b) = '(' : (show a) ++ (show o) ++ (show b) ++ ")" | ||
show (G xs) = '[' : (concatMap (\x -> show x) xs) ++ "]" | show (G xs) = '[' : (concatMap (\x -> show x) xs) ++ "]" | ||
| - | + | ||
compile = bytes . parse | compile = bytes . parse | ||
| - | + | ||
| - | parse = stripG . | + | parse = stripG . G . foldr ((.) . prec) id "+-*/%^" . pToks . parseNOp . map C |
| - | + | ||
parseNOp [] = [] | parseNOp [] = [] | ||
parseNOp ((N num):(C ch):inp) | parseNOp ((N num):(C ch):inp) | ||
| Line 27: | Line 30: | ||
parseNOp ((C ch):inp) | ch `elem` "+-*/^%" = parseNOp (Op 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` " \t\r\n" = parseNOp inp | ||
| - | parseNOp ( | + | 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 | --Groups an array of tokens if it needs to be | ||
g (x:xs) | null xs = x | g (x:xs) | null xs = x | ||
g xs = G xs | g xs = G xs | ||
| - | + | ||
--Returns parsed tokens/stream remainder | --Returns parsed tokens/stream remainder | ||
pToks = fst . parseG | pToks = fst . parseG | ||
pRem = snd . parseG | pRem = snd . parseG | ||
| - | + | ||
parseG [] = ([], []) | parseG [] = ([], []) | ||
parseG [(G ts)] = (ts, []) | parseG [(G ts)] = (ts, []) | ||
| Line 42: | Line 47: | ||
parseG ((C ')') : inp) = ([], inp) | parseG ((C ')') : inp) = ([], inp) | ||
parseG (i:inp) = (i : (pToks inp), pRem 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]) | 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 | --Traverses groups, applies operators to their immediate arguments | ||
prec mo [] = [] | prec mo [] = [] | ||
| - | |||
prec mo (a:(Op o):b:inp) | o == mo = prec mo ((aPrec mo a (Op o) b) : inp) | 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 ((App a o b):inp) = (aPrec mo a o b) : (prec mo inp) | ||
prec mo (x:inp) = x : (prec mo inp) | prec mo (x:inp) = x : (prec mo inp) | ||
| - | + | ||
--Removes any vestigial grouping | --Removes any vestigial grouping | ||
stripG (App a o b) = App (stripG a) o (stripG b) | stripG (App a o b) = App (stripG a) o (stripG b) | ||
| Line 57: | Line 62: | ||
stripG (G (x:xs)) = error $ "error: " ++ show (x:xs) ++ " <- improper infix nesting here" | stripG (G (x:xs)) = error $ "error: " ++ show (x:xs) ++ " <- improper infix nesting here" | ||
stripG x = x | stripG x = x | ||
| - | + | ||
--Converts to a byte format | --Converts to a byte format | ||
bytes (C x) = error ("Invalid character: " ++ [x]) | bytes (C x) = error ("Invalid character: " ++ [x]) | ||
| Line 64: | Line 69: | ||
bytes (App a o b) = (bytes a) ++ (bytes b) ++ (bytes o) | bytes (App a o b) = (bytes a) ++ (bytes b) ++ (bytes o) | ||
bytes x = error ("Error, invalid: " ++ show x) | 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> | toBytes n x = map (\i -> (x `div` 2^(i*8)) `mod` 256 ) [(n-1),(n-2)..0]</haskell> | ||
Current revision
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]
