Talk:Haskell Quiz/Bytecode Compiler/Solution Michael Sloan

import Char (digitToInt)
 
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 . head . foldl (\f c -> prec c . f) 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 (a:inp)                               = a : 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)
 
--Traverses groups, applies operators to their immediate arguments
prec mo [] = []
prec mo ((G xs):inp) = (g $ prec mo xs) : (prec mo inp)
prec mo (a:(Op o):b:inp) | o == mo = prec mo ((App (g $ prec mo [a]) (Op o) (g $ prec mo [b])) : inp)
prec mo ((App a o b):inp)          = (App (g $ prec mo [a]) o (g $ prec mo [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 = error $ "error: " ++ show (x:xs) ++ " <- improper infix nesting here"
stripG (G (x:xs)) = stripG x
stripG x = x
 
--Converts to a byte format
bytes (N n)       = 1 + x : toByteArray n (2^x) where x = fromEnum (abs n >= 2^15)
bytes (Op ch)     = return $ case ch of '+' -> 10; '*' -> 11; '^' -> 12; '/' -> 14; '%' -> 15
bytes (App a o b) = concat $ map bytes [a,o,b]
bytes (C x)       = error  $ "Invalid character: " ++ [x]
bytes x           = error  $ "Error, invalid: "    ++ show x
 
toByteArray x n = map (\i -> (x `div` 2^(i*8)) `mod` 256 ) [(n-1),(n-2)..0]