ふえぇ言語のインタプリタ(ver0.1)

gistfile1.hs

{-
ふえぇ言語のインタプリタ(ver0.1)

構文:
    ふ -> S
    ぇ -> K
    [F]え[G] -> [F][G]
    [F]…[G] -> [G][F]
[F]、[G]は任意の式
-}

import Control.Arrow
import Control.Applicative
import Data.Char (chr, ord)
import Data.List
import System.Exit
import System.Environment
import System.IO

infixl 9 :$
data Expr = Expr :$ Expr | I | K | S | Inc | Export {-# UNPACK #-} !Int deriving Show

apply :: Expr -> Expr -> Expr
apply (S :$ x :$ y) z = apply x z `apply` apply y z
apply (K :$ x) y = x
apply I x = x
apply Inc (Export x) = Export $! x + 1
apply f x = f :$ x

eval :: Expr -> Expr
eval (x :$ y) = eval x `apply` eval y
eval x = x

cons :: Expr -> Expr -> Expr
cons a b = S :$ (S :$ I :$ (K :$ a)) :$ (K :$ b)

church :: Int -> Expr
church 32 = S :$ (K :$ (S :$ (S :$ (K :$ S) :$ K) :$ I)) :$ (S :$ (S :$ I :$ I) :$ I :$ (S :$ (S :$ (K :$ S) :$ K) :$ I))
church 64 = S :$ (S :$ (S :$ (K :$ S) :$ K)) :$ (S :$ I :$ I) :$ (S :$ (S :$ (K :$ S) :$ K) :$ I)
church 128 = S :$ (K :$ (S :$ (S :$ (K :$ S) :$ K) :$ I)) :$ (S :$ (S :$ (S :$ (K :$ S) :$ K)) :$ (S :$ I :$ I) :$ (S :$ (S :$ (K :$ S) :$ K) :$ I))
church 1 = I
church 0 = K :$ I
church n = S :$ (S :$ (K :$ S) :$ K) :$ church (n - 1)

church256 :: Expr
church256 = S :$ I :$ I :$ (S :$ I :$ I :$ (S :$ (S :$ (K :$ S) :$ K) :$ I))

endofstream :: Expr
endofstream = cons church256 endofstream

encode :: String -> Expr
encode = foldr cons endofstream . map (church . ord)

export :: Expr -> Int
export (Export x) = x
export _ = error "invalid output format (result was not a number)"

realize :: Expr -> Int
realize expr = export $ expr `apply` Inc `apply` Export 0

sApp :: Expr -> Expr -> Expr
sApp I x = x
sApp (K :$ x) y = x
sApp f g = f :$ g

parse :: String -> Expr -> (Expr, String)
parse ('ふ':xs) f = parse xs (f `sApp` S)
parse ('ぇ':xs) f = parse xs (f `sApp` K)
parse ('え':xs) f = (f `sApp` g, xs')
    where
        (g, xs') = parse xs I
parse ('…':xs) f = (g `sApp` f, xs')
    where
        (g, xs') = parse xs I
parse (_:xs) f = parse xs f
parse "" f = (f, "")

output :: Expr -> IO ()
output expr
    | x < 256 = putChar (chr x) >> (output $ apply expr $ K :$ I)
    | x == 256 = exitWith ExitSuccess
    | otherwise = exitWith $ ExitFailure $ x - 256
    where
        x = realize $ apply expr K

main = do
    (path:_) <- getArgs
    prog <- fst . flip parse I <$> readFile path
    input <- encode <$> getContents
    output $ eval $ prog :$ input