blog-static/code/dawn/Ucc.hs

65 lines
1.6 KiB
Haskell
Raw Normal View History

module Ucc where
import UccGen
import Text.Parsec
import Data.Functor.Identity
import Control.Applicative hiding ((<|>))
import System.IO
instance Show Intrinsic where
show Swap = "swap"
show Clone = "clone"
show Drop = "drop"
show Quote = "quote"
show Compose = "compose"
show Apply = "apply"
instance Show Expr where
show (E_int i) = show i
show (E_quote e) = "[" ++ show e ++ "]"
show (E_comp e1 e2) = show e1 ++ " " ++ show e2
instance Show Value where
show (V_quote e) = show (E_quote e)
type Parser a = ParsecT String () Identity a
intrinsic :: Parser Intrinsic
intrinsic = (<* spaces) $ foldl1 (<|>) $ map (\(s, i) -> try (string s >> return i))
[ ("swap", Swap)
, ("clone", Clone)
, ("drop", Drop)
, ("quote", Quote)
, ("compose", Compose)
, ("apply", Apply)
]
expression :: Parser Expr
expression = foldl1 E_comp <$> many1 single
where
single
= (E_int <$> intrinsic)
<|> (fmap E_quote $ char '[' *> spaces *> expression <* char ']' <* spaces)
parseExpression :: String -> Either ParseError Expr
parseExpression = runParser expression () "<inline>"
eval :: [Value] -> Expr -> Maybe [Value]
eval s e =
case eval_step s e of
Err -> Nothing
Final s' -> Just s'
Middle e' s' -> eval s' e'
main :: IO ()
main = do
putStr "> "
hFlush stdout
str <- getLine
case parseExpression str of
Right e ->
case eval [] e of
Just st -> putStrLn $ show st
_ -> putStrLn "Evaluation error"
_ -> putStrLn "Parse error"
main