Demo Factor basis for the non-classical paradigms and language course

Factor.hs

module Factor where

import Control.Monad.State

-- We can put integer literals or quotations on the stack
data Stackable = IntLiteral Int
               | FQuotation (Factor ())

-- Shortcut name
type Stack = [Stackable]

-- The system state is the stack and the definitions
data SystemState = SystemState { stack :: Stack
                               , definitions :: [(String, Factor ())] }

-- Factor is a state transformed monad embedding an IO,
-- so that we can perform IO operations if needed using
-- lift (see the definition of executeDot for example).
type Factor = StateT SystemState IO

-- applyStack is a generic procedure that applies a function
-- that takes the original stack and returns the new stack in
-- the Factor monad (so that it can perform IO if needed or
-- change definitions), and it returns the old stack in case
-- this is useful.
applyStack :: (Stack -> Factor Stack) -> Factor Stack
applyStack f = do
  state <- get
  let oldStack = stack state
  newStack <- f oldStack
  put $ state { stack = newStack }
  return oldStack

-- Apply a stack transforming function which does not use
-- the definitions or the IO.
modifyStack :: (Stack -> Stack) -> Factor Stack
modifyStack f = applyStack (return . f)

-- Get the current stack
getStack :: Factor Stack
getStack = modifyStack id

-- Replace the current stack
putStack :: Stack -> Factor ()
putStack s = void $ applyStack $ const $ return s

-- Push a stackable onto the stack
push :: Stackable -> Factor ()
push x = void $ modifyStack (x :)

-- Return the top of stack (must not be empty)
pop :: Factor Stackable
pop = liftM head $ modifyStack tail

-- Add a definition in the current environment
addDefinition :: String -> Factor () -> Factor ()
addDefinition name def = do
  state <- get
  put $ state { definitions = (name, def) : definitions state }

-- dup implementation
executeDup :: Factor ()
executeDup = do
  tos <- pop
  push tos
  push tos

-- call implementation
executeCall :: Factor ()
executeCall = do
  tos <- pop
  case tos of
    FQuotation f -> f
    _            -> error "cannot apply a non-quotation"

-- . implementation
executeDot :: Factor ()
executeDot = do
  tos <- pop
  let s = case tos of
            IntLiteral i -> show i
            FQuotation _ -> "<quotation>"
  lift $ putStrLn s

-- Shortcut to ease binary arithmetic operators implementation
binOp :: (Int -> Int -> Int) -> Factor ()
binOp op = do
  tos  <- pop
  tos' <- pop
  case (tos', tos) of
    (IntLiteral a, IntLiteral b) -> push $ IntLiteral $ a `op` b
    _                            -> error "non-integer arguments for binop"

-- Push an integer literal to the stack
pushInt :: Int -> Factor ()
pushInt = push . IntLiteral

-- Push a quotation to the stack
pushQuotation :: Factor () -> Factor ()
pushQuotation = push . FQuotation

-- Execute a single command or push an integer onto the stack
executeCommand :: String -> Factor ()
executeCommand s = do
  defs <- liftM definitions get
  case lookup s defs of
    Just f  -> f
    Nothing -> pushInt $ read s

-- Execute commands or push integers onto the stack
executeCommands :: [String] -> Factor ()
executeCommands = mapM_ executeCommand

-- Parse the current line and execute commands
executeParsed :: String -> Factor ()
executeParsed = executeCommands . words

-- Initial environment
initialDefinitions :: [(String, Factor ())]
initialDefinitions = [("call", executeCall),
                      ("dup", executeDup),
                      ("+", binOp (+)),
                      ("-", binOp (-)),
                      ("*", binOp (*)),
                      ("/", binOp div),
                      (".", executeDot)]

-- This test should print: 1 2 10 16 <quotation> 256
test :: Factor ()
test = do
  -- Add definition for sq
  addDefinition "sq" $ executeParsed "dup *"
  -- Print 1 2 10 16 and let 2 on the stack
  executeParsed "2 2 1 . . 30 20 - . 4 sq ."
  -- Push a quotation and print <quotation>
  pushQuotation $ executeParsed "sq sq sq"
  executeParsed "dup ."
  -- Call the quotation and print 256
  executeParsed "call ."

-- Run the test with the initial definitions
main :: IO ()
main = void $ runStateT test $ SystemState [] initialDefinitions