Haskell Quiz/Bytecode Compiler/Solution Pepe Iborra

This extremely simple solution declares the type of Expressions as an instance of Num, thus don't really need to define a parser as long as the compiler is launched interpreted via 'ghc -e' . This trick is inspired from the Ruby solution.

As far as I know it passes all the tests in the original suite, but due to the parsing trick some expressions need parentization. Namely expressions with negations such as 1*-1, which needs to be expressed as 1*(-1).

In order to launch the compiler from the command line you should use the script:

ghc bytecode.hs -fno-warn-missing-methods -e "process ($1)"

And then:

sh compiler.sh 1+2

The solution:

import Data.Bits
import Prelude hiding ((**), mod,div,const)

process :: Exp -> String
process = output . flip generate [] 

data Exp = Exp :+ Exp
         | Exp :/ Exp
         | Exp :* Exp
         | Exp :- Exp
         | Exp :^ Exp
         | Exp :% Exp
         | Val Int
   deriving (Show, Eq)

data ByteCode = Const Int
              | LConst Int
              | ADD
              | SUB
              | MUL
              | POW
              | DIV
              | MOD
              | SWAP
   deriving (Show,Eq)

type Stack = [ByteCode]

-------------------
-- The "Parser"
-------------------

instance Fractional Exp where
  (/) = (:/)

instance Num (Exp) where
  (+) = (:+)
  (-) = (:-)
  (*) = (:*)
  negate (Val i) = Val (negate i)
  fromInteger = Val . fromIntegral
  
(**) = (:^)
(%) = (:%) 

----------------------
-- Smart constructors
----------------------
min_small = -32768
max_small = 32767
i `inBounds` (min,max) = i >= min &&  i <= max

add,sub,mul,pow,div,mod,swap :: Stack -> Stack
const i = if i `inBounds` (min_small,max_small) then Const i else LConst i
add  = (++[ADD])
sub  = (++[SUB])
mul  = (++[MUL])
pow  = (++[POW])
div  = (++[DIV])
mod  = (++[MOD])
swap = (++[SWAP])

---------------------

generate :: Exp -> Stack -> Stack
generate (Val i)  = (++[const i])
generate (x :+ y) = binaryOp x y add
generate (x :- y) = binaryOp x y sub
generate (x :* y) = binaryOp x y mul
generate (x :/ y) = binaryOp x y div
generate (x :^ y) = binaryOp x y pow
generate (x :% y) = binaryOp x y mod

binaryOp :: Exp -> Exp -> (Stack -> Stack) -> Stack -> Stack
binaryOp x y f = f . generate y . generate x

bytes :: Int -> [Int]
bytes a = a .&. 255 : bytes (a `shiftR` 8)

represent :: ByteCode -> [Int]
represent (Const i)  = 1 : reverse( take 2 (bytes i))
represent (LConst i) = 2 : reverse( take 4 (bytes i))
represent ADD = [10]
represent SUB = [11]
represent MUL = [12]
represent POW = [13]
represent DIV = [14]
represent MOD = [15]
represent SWAP= [160]

output :: Stack -> String
output = show . concatMap represent