{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}

import Data.STRef    (STRef, newSTRef, readSTRef, modifySTRef)
import Control.Monad (when)
import Control.Monad.ST (ST, runST)

class (Monad m) => NumMod l r m where
  (+=) :: l -> r -> m ()
  (-=) :: l -> r -> m ()
  (*=) :: l -> r -> m ()

instance Num a => NumMod (STRef s a) (STRef s a) (ST s) where
  a += b    = readSTRef b >>= \b -> modifySTRef a ((+) b)
  a -= b    = readSTRef b >>= \b -> modifySTRef a ((+) (negate b))
  a *= b    = readSTRef b >>= \b -> modifySTRef a ((*) b)

instance Num a => NumMod (STRef s a) a (ST s) where
  a += b    = modifySTRef a ((+) b)
  a -= b    = modifySTRef a ((+) (negate b))
  a *= b    = modifySTRef a ((*) b)

var = newSTRef

def :: (forall s. ST s (STRef s a)) -> a
def = \x -> runST $ x >>= readSTRef

class BooleanL b where toBool :: b -> Bool
instance BooleanL Bool where toBool = id
instance (Num a, Eq a) => BooleanL a where toBool n = n /= 0

while :: (BooleanL a) => STRef s a -> ST s () -> ST s ()
while i st = fmap toBool (readSTRef i) >>= \p ->
             when p $ st >> while i st

assert b str = when (not b) . return $ error str

factorial :: Integer -> Integer
factorial n = def $ do
    assert (n >= 0) "Negative factorial"
    ret <- var 1
    i   <- var n
    while i $ do
        ret *= i
        i -= 1
    return ret

main = print . factorial $ 1000