Function{al,ing} RL interpreter written in Haskell

rl.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}

import System.Environment (getArgs)
import System.Exit        (ExitCode(..), exitWith)
import Data.Maybe         (listToMaybe, fromMaybe)
import Data.Fixed         (mod', div')

showDouble :: Double -> String
showDouble n = if n `mod'` 1 == 0 then show (n `div'` 1) else show n

maybeRead :: Read a => String -> Maybe a
maybeRead s0 = listToMaybe [a | (a,s1) <- reads s0,("","") <- lex s1]

eitherRead :: Read a => String -> Either String a
eitherRead x = maybe (Left x) Right $ maybeRead x

newtype Dict = Dict [(String, Runner)]

type Runner = Dict -> [Double] -> [Either String Double] -> IO [Double]

run                  :: Runner
run d s (Right x:xs) = run d (x:s) xs
run d s (Left  x:xs) = word x d s xs
run _ s []           = return s

find :: Dict -> String -> [Double] -> [Either String Double] -> IO [Double]
find (Dict d) w = fromMaybe (error $ "unknown word " ++ w) (lookup w d) $ Dict d

word :: String -> Dict -> [Double] -> [Either String Double] -> IO [Double]
word ":" d xs (Left w:ws) = define d xs w ws
word "bye" _ _ _ = return [0]

word w d xs ws = find d w xs ws

define :: Dict -> [Double] -> String -> [Either String Double] -> IO [Double]
define (Dict d) xs w ws = run (Dict $ (w, de):d) xs rest where
    de (Dict d') xs' ws' = run (Dict $ (w, de):d') xs' (block ++ ws')
    (block, _:rest) = break (== Left ";") ws

parse :: String -> [Either String Double]
parse = map eitherRead . words

source :: [String] -> IO String
source [] = getContents
source as = fmap concat $ mapM readFile as

exit :: Int -> IO a
exit 0 = exitWith ExitSuccess
exit n = exitWith $ ExitFailure n

main :: IO ()
main = getArgs
   >>= source
   >>= run library (repeat 0) . parse
   >>= exit . (`div'` 1) . head

library :: Dict
library = Dict
    ( map (fmap iowrapper)
      [ "."    ~> \(x:xs) -> putStrLn (showDouble x) >> return xs
      ] ++ map (fmap wrapper)
      [ "pick" ~> \(x:xs) -> (xs !! (x `div'` 1)):xs
      , "roll" ~> \(x:xs) -> let n = (x `div'` 1)
                                 (h, x:r) = splitAt (n - 1) xs
                             in x:h ++ r

      -- : dup 0 pick ;
      , "dup"  ~> \(x:xs)     -> x:x:xs

      -- : 2dup 1 pick 1 pick ;
      , "2dup" ~> \(x:x':xs)  -> x:x':x:x':xs

      -- : swap 1 roll ;
      , "swap" ~> \(x:x':xs)  -> x':x:xs

      -- : over 1 pick ;
      , "over" ~> \(x:x':xs)  -> x':x:x':xs

      -- : rot 2 roll ;
      , "rot"  ~> \(x:y:z:xs) -> z:x:y:xs

      -- : tuck 1 roll 1 pick ;
      , "tuck" ~> \(x:y:xs)   -> x:y:x:xs

      , "not"  ~> \case (0:xs) -> 1:xs; (x:xs) -> 0:xs
      , "drop" ~> tail
      , "+"    ~> op   (+)
      , "-"    ~> op   (-)
      , "*"    ~> op   (*)
      , "/"    ~> op   (/)
      , "pow"  ~> op   (**)
      , "mod"  ~> op   mod'
      , ">"    ~> bop  (>)
      , "<"    ~> bop  (<)
      , "<="   ~> bop  (<=)
      , ">="   ~> bop  (>=)
      , "="    ~> bop  (==)
      , "and"  ~> tbop (&&)
      , "or"   ~> tbop (||)
      , "sqrt" ~> fn sqrt
      , "sin"  ~> fn sin
      , "cos"  ~> fn cos
      , "tan"  ~> fn tan
      -- more words here...
      ]
    ) where
        fn f (x:xs) = f x:xs

        op   f (x':x:xs) = f x x':xs
        bop  f (x':x:xs) = fromB (f x x'):xs
        tbop f (x':x:xs) = fromB (f (toB x) (toB x')):xs

        fromB b = if b then 1 else 0
        toB = (/= 0)

        iowrapper f d xs ws = f xs >>= flip (run d) ws
        wrapper f d xs ws = run d (f xs) ws

        (~>) = (,)