Hvm.hs: an exercise in Haskell golf

[kpreid]

import Char
import Debug.Trace
import System.Environment
import Control.Monad.Fix

{-
  Hvm.hs
  By Kevin Reid, 2008-06-15

  This is an implementation of the virtual machine described at 
  <http://www.hacker.org/hvm/>. It was designed to fit into a single IRC line
  so that its definition could be put into lambdabot
  <http://www.haskell.org/haskellwiki/Lambdabot>, and its inspiration and
  creation was documented at <http://swhack.com/logs/2008-06-15>.

  Haskell source not in HTML: <http://switchb.org/kpreid/2008/Hvm.hs>
  Non-blog location: <http://switchb.org/kpreid/2008/Hvm.html>

  Explanation of variables:

    r = VM execution function of call stack, memory, instruction pointer, and 
        operand stack
    c = call stack
    m = memory
    i = instruction pointer
    j = instruction pointer plus one
    o = operand stack

    a = arithmetic handler
    h = proceed with instruction pointer and operation stack modification
    g = proceed with operand stack modification

    z:x = one value popped from operand stack
    z:w:e = two values popped from operand stack
    k:l = one value popped from call stack

    d, t: slice lists using z as length

  To make it fit in IRC, discard comments, imports, and "main", replace 
  all line breaks with semicolons as appropriate, and discard the ' ' and _ 
  cases (i.e. the interpreter will not support whitespace or report invalid 
  characters).
    perl -0777 -pe 's/\A.*(?=^s)//ms; s/\s*main .*//; s/--.*$//mg;
                    s/\n */;/g; s/[;\s]*(where|let)[;\s]*/$1 /g;
                    s/;'\'' '\''->g o;_->error\$show\(p!!i\)//;'
-}

s p=r[](fix(0:))0[]
  where
   r c m i o=--trace (show (m,i,(if length p<=i then '!' else p !! i),(reverse o),c)) $
     let a(&)=g$w&z:e
         j=1+i
         h=r c m
         g=h j
         z:x=o
         w:e=x
         k:l=c
         d=drop(1+z)
         t=take z
      in case(p++"!")!!i of
         'p'->show z++g x
         'P'->chr(mod z 128):g x
         d|isDigit d->g$ord d-48:o
         '+'->a(+)
         '-'->a(-)
         '*'->a(*)
         '/'->a div
         ':'->g$signum(w-z):e
         'g'->h(z+j)x
         '?'->h(i+case w of 0->z;_->1)e
         'c'->r(j:c)m z x
         '$'->r l m k o
         '<'->g$m!!z:x
         '>'->r c(t m++w:d m)j e
         '^'->g$x!!z:x
         'v'->g$x!!z:t x++d x
         'd'->g x
         '!'->""
         ' '->g o
         _->error$show(p!!i)

main = do [p] <- getArgs; putStrLn $ s p