Universal Registry Machine and a relocatable DSL for it

urm.hs

{-# LANGUAGE RecursiveDo #-}

import Control.Monad
import Control.Monad.Free
import Control.Monad.Writer
import Data.Functor.Identity

data Instruction = End
                 | Inc Int Int
                 | DeB Int Int Int
                 deriving (Eq, Show)

targetRegister :: Instruction -> Maybe Int
targetRegister End = Nothing
targetRegister (Inc r _) = Just r
targetRegister (DeB r _ _) = Just r

type Program = [Instruction]

end = tell [End]
inc n t = tell [Inc n t]
deb n t1 t2 = tell [DeB n t1 t2]

type State = [Int]

stepProgram :: Program -> State -> State
stepProgram program state@(pc:_) = newState where
  instruction = program !! pc
  newState = case instruction of
    End -> state
    Inc r t -> set 0 t $ set r (get r state + 1) $ state
    DeB r tt tf -> let val = get r state
                   in  if val > 0
                      then set 0 tt $ set r (val - 1) $ state
                      else set 0 tf state
  -- read at provided position or default to 0
  get _ []    = 0
  get 0 (v:_) = v
  get n (_:vs) = get (n-1) vs

  -- set at default position, filling in missing positions with 0
  set 0 v' []     = [v']
  set 0 v' (_:vs) = v' : vs
  set n v' []     = 0  : set (n-1) v' []
  set n v' (v:vs) = v  : set (n-1) v' vs


runProgram :: Program -> State -> [State]
runProgram p initial = initial : trace where
  trace = map snd $ takeWhile (uncurry (/=)) $ zip steps (tail steps)
  steps = iterate (stepProgram p) initial


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

example :: Program  -- r1 <- r2 + r3
example = execWriter $ do
  deb 2 1 2 -- 0
  inc 1 0   -- 1
  deb 3 3 4 -- 2
  inc 1 2   -- 3
  end       -- 4


exampleStates :: [State]
exampleStates = runProgram example [0,0,1,2]

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

-- registers are not managed, just an alias for readability
type Register = Int

-- positions are managed and thus opaque, so "pointer arithemtic" is discuraged
newtype Position = Position { getPosition :: Int } deriving (Eq, Show)

-- code writer is a function that will generate position relative code and
-- produce a value on the side (for other effecs)
newtype CodeWriter a = CodeWriter { unCodeWriter :: Position -> ([Instruction], a)
                                  } deriving (Functor) -- functor is obvious

instance Applicative CodeWriter where
  -- applicative is generic
  pure = return
  (<*>) = ap

instance Monad CodeWriter where
  return a = CodeWriter $ \_ -> ([], a)

  -- bind will adjut position for the second writer, and concatenate results
  CodeWriter w1 >>= f = CodeWriter $ \p@(Position pi) ->
    let (is1, a) = w1 p
        CodeWriter w2 = f a
        (is2, b) = w2 (Position $ pi + length is1)
    in  (is1 ++ is2, b)

instance MonadFix CodeWriter where
  -- produces a new writer that ties the know at the provided position
  mfix f = CodeWriter $ \p ->
    let CodeWriter w = f a
        (is, a) = w p
    in  (is, a)

instruction' :: Instruction -> CodeWriter ()
instruction' i = CodeWriter $ \_ -> ([i], ())

label' :: CodeWriter Position
label' = CodeWriter $ \p -> ([], p)

end' :: CodeWriter ()
end' = instruction' End

inc' :: Register -> Position -> CodeWriter ()
inc' n t = instruction' $ Inc n (getPosition t)

deb' :: Register -> Position -> Position -> CodeWriter ()
deb' n t1 t2 = instruction' $ DeB n (getPosition t1) (getPosition t2)

-- all the heavy lifting is done int the Monad instance so this just runs the
-- writer at position 0
writeCode :: CodeWriter a -> Program
writeCode (CodeWriter w) = fst (w $ Position 0)


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

-- equivalent to `example`
example2 :: Program
example2 = writeCode $ do
  addReg 2
  addReg 3
  end'
  where
  addReg r = mdo
    start <- label'
    deb' r go done
    go <- label'
    inc' 1 start
    done <- label'
    return ()

This concept can be used with a more rich instruction language - e.g. a real-life assembly can be lifted into a DSL.