Some solution, still debug or (de)compile are missing.

Synacor.hs

{-# LANGUAGE LambdaCase #-}

module Main where

import qualified Data.IntMap.Strict as M
import Data.Word
import Data.Char
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.State.Lazy
import qualified Data.Binary as DB
import qualified Data.ByteString.Lazy as BS
import Data.Bits

data Machine = Machine
  { mem   :: M.IntMap Word16
  , stack :: [Word16]
  , ip    :: Word16
  , input :: String
  }

type Syn = State Machine

run :: Machine -> String
run m = evalState (run') m

data OP = OP 
  { opcode :: Word16
  , desc   :: String
  , leng   :: Word16
  , code   :: Syn String
  }

microcode :: [OP]
microcode =
 [ OP  0 "halt" 1 (nope)
 , OP  1 "set"  3 (store <$> getMem 1 <*$> getValue 2 >> runN 3)
 , OP  2 "push" 2 (push <$$> getValue 1 >> runN 2)
 , OP  3 "pop"  2 (pop >>= \case Just v -> store <$> getMem 1 <*$> pure v >> runN 2; Nothing -> (error "empty stack") )
 , OP  4 "eq"   4 (do b <- getValue 2; c <- getValue 3; store <$> getMem 1 <*$> pure (if b == c then 1 else 0); runN 4)
 , OP  5 "gt"   4 (do b <- getValue 2; c <- getValue 3; store <$> getMem 1 <*$> pure (if b > c then 1 else 0); runN 4)
 , OP  6 "jmp"  2 (setip <$$> getValue 1 >> run')
 , OP  7 "jt"   3 (do a <- getValue 1; if (a/=0) then (setip <$$> getValue 2 >> run') else runN 3)
 , OP  8 "jf"   3 (do a <- getValue 1; if (a==0) then (setip <$$> getValue 2 >> run') else runN 3)
 , OP  9 "add"  4 (store <$> getMem 1 <*$> ( (`mod` 32768) <$> ((+) <$> getValue 2 <*> getValue 3)) >> runN 4)
 , OP 10 "mult" 4 (store <$> getMem 1 <*$> ( (`mod` 32768) <$> ((*) <$> getValue 2 <*> getValue 3)) >> runN 4)
 , OP 11 "mod"  4 (store <$> getMem 1 <*$> (mod <$> getValue 2 <*> getValue 3) >> runN 4)
 , OP 12 "and"  4 (store <$> getMem 1 <*$> ((.&.) <$> getValue 2 <*> getValue 3) >> runN 4)
 , OP 13 "or"   4 (store <$> getMem 1 <*$> ((.|.) <$> getValue 2 <*> getValue 3) >> runN 4)
 , OP 14 "not"  3 (store <$> getMem 1 <*$> ((.&. 32767) . complement <$> getValue 2) >> runN 3)
 , OP 15 "rmem" 3 (store <$> getMem 1 <*$> (retrive <$$> getValue 2) >> runN 3)
 , OP 16 "wmem" 3 (store <$> getValue 1 <*$> getValue 2 >> runN 3)
 , OP 17 "call" 2 (push . (+2) <$$> gets ip >> setip <$$> getValue 1 >> run')
 , OP 18 "ret"  1 ((\case Just v -> setip v >> run'; Nothing -> nope) <$$> pop )
 , OP 19 "in"   2 ((:) <$> (chr . fromIntegral <$> getValue 1) <*> runN 2)
 , OP 20 "out"  2 (store <$> getMem 1 <*$> getCh >> runN 2)
 , OP 21 "nope" 1 (runN 1)
 ]

infixl 4 <$$>, <*$>
(<$$>):: (Monad f, Functor f) => (a -> f b) -> f a -> f b
(<$$>) a b = join $ a <$> b

(<*$>) :: (Monad f, Functor f) => f (a -> f b) -> f a -> f b
(<*$>) a b = do { x1 <- a; x2 <- b; x1 x2 }

run' :: Syn String
run' = do
 i <- getMem 0
 code (microcode !! fromEnum i)

runN :: Word16 -> Syn String
runN i = incip i >> run'

getCh :: Syn Word16
getCh = do
    (c:input') <- gets input
    modify $ \s -> s{input = input'}
    return $ fromIntegral $ ord c

push :: Word16 -> Syn ()
push v = modify $ \s -> s{stack = v : stack s}

pop :: Syn (Maybe Word16)
pop = do
   v <-gets stack
   if null v 
     then return Nothing
     else do
       modify $ \s -> s{stack = tail( stack s)}
       return $ Just $ head v

getValue :: Word16 -> Syn Word16
getValue n = do
   i <- getMem n
   if (i > 32767) 
     then (retrive i)
     else (return i)

retrive :: Word16 -> Syn Word16
retrive addr = (M.findWithDefault 0 (fromIntegral addr)) <$> gets mem

store :: Word16 -> Word16 -> Syn ()
store addr value = modify $ \s -> s{mem = M.insert (fromIntegral addr) value (mem s)}

nope :: Syn String
nope = return ""

load :: [Word16] -> String -> Machine
load prog i = Machine (M.fromAscList $ zip [0..] prog) [] 0 i 

incip :: Word16 -> Syn ()
incip n = modify $ \s -> s{ip = ip s + n}

setip :: Word16 -> Syn ()
setip c = modify $ \s -> s{ip = c}

getMem :: Word16 -> Syn Word16
getMem offset = (M.findWithDefault 0) <$> gets (fromIntegral . (+offset) . ip) <*> gets mem

decodee :: BS.ByteString -> [Word16]
decodee bs = if BS.null bs then [] else let b2 = (BS.take 2 bs) in (DB.decode $ BS.pack [ b2 `BS.index` 1 , BS.head b2] ) : decodee (BS.drop 2 bs)


main::IO()
main = do
    ma <- decodee <$> BS.readFile "challenge.bin"
    inp <- getContents
    putStrLn $ run (load ma inp)