phorth---（その1.7）main関数---簡単な対話型シェル

デバグ

オペレータsubの定義が間違ってました．

-- procExp i (Invoke "sub") = procStack i (\(x1:x2:xs) -> (x1-x2):xs)
procExp i (Invoke "sub") = procStack i (\(x1:x2:xs) -> (x2-x1):xs)

スタックの順番を間違えてました．

簡単な対話型シェル（REPL: Read-Eval-Print Loop）

入出力のインタフェースとして，簡単な対話型シェルを作っておきます．Gaucheの対話型シェルがgoshという名前なのを真似して，phorthのシェルをphoshと名づけました．

initInterp = Interp{ stack=[], dict=Map.empty}

main :: IO ()
main = repl initInterp
repl :: Interp -> IO ()
repl i = do putStr ("phosh<"++(show $ length $ stack i)++"> ") 
            hFlush stdout
            src <- getLine `catch` (\e -> return ":q")
            case words src of
                (":q": _) -> return ()
                otherwise -> repl' i src 

repl'::Interp -> String -> IO ()
repl' i src = case (parse phorthProg "" src) of
                  Left err  -> do putStr "parse Error ar"
                                  print err
                  Right ast -> do i' <- interp i ast
                                  repl i'

main関数として，空っぽのインタプリータが引数として与えられた対話型シェルreplを定義します．repl本体はみての通り，プロンプトを表示して，入力を一行ずつ読み込んで処理して，また自分自身を読み込んで処理するループです．ただし，行頭に``:q''がきたときには処理そのものを終わらせるため，phorth本体の前にシェルそのものへの命令がないかチェックしています．

このシェルには仕様上の大きな問題があります．それは「一行単位」だということそのものです．例えば，オペレータを新規に定義するために長いコードが必要な場合でも改行ができないのです．改行してしまうとその段階で処理されてしまうので，パーサエラーとなります．

これを回避するには，harrorthと同様に，``{''，``}''そのものを「インタープリータの状態を変える」オペレータとして，インタープリータそのものに状態（入力の途中か否か）を持たせる必要があると思いますが，厄介そうなので例によって保留です．

また，repl関数もやはり引数としてInterp型のインタープリータを持たざると得ません．同じ物を延々と引数としてもつのは状態を持って歩いてるのと同じで，これは隠蔽すべき対象です．

その2では（シェルの問題は保留して）この隠蔽を考えます．

それにしても・・・案外簡単に，いい加減とはいえ，シェルつきRPN電卓ができました．ここまででコードは181行ので一個のファイルだけです．

そろそろファイル分割を考えたほうがいいのかもしれません．

長いけどここまでのソースコード全文晒し

import System.IO
import Text.ParserCombinators.Parsec
import qualified Data.Map as Map

-- AST
type AST = [Exp]

data Exp =   Push Literal
           | Invoke Word 
           | Name Word
           | Block AST
           deriving (Show, Eq)
type Literal = Integer
type Word = String


-- Parser
phorthProg::Parser AST
phorthProg = do ast <- phorth
                eof
                return ast

phorth::Parser AST
phorth = do skipMany space
            sepEndBy1 phorthExp (skipMany space)

phorthExp::Parser Exp
phorthExp = literal <|> word <|> name <|> block 

literal::Parser Exp
literal = do sign <- option ' ' (char '-')
             num  <- (many1 digit)
             return (Push (read $ sign:num))

opname::Parser String
opname = do first  <- letter 
            others <- many (letter <|> digit)
            return $ first:others
         <|>
            string "=="

word::Parser Exp
word = opname >>= \x ->  return $ Invoke x


name::Parser Exp
name = char '/' >> opname >>= \x ->  return $ Name x

block::Parser Exp
block = do char '{'
           ast <- phorth
           char '}'
           return $ Block ast

-- Evaluator

type Stack = [Stackable]
data Stackable =  Pushed Literal
                | Opname Word
                | Code AST
                deriving Eq

instance Num Stackable where
    (+) (Pushed a) (Pushed b) = Pushed (a+b)
    (*) (Pushed a) (Pushed b) = Pushed (a*b)
    abs (Pushed a)            = Pushed $ abs a
    signum (Pushed a)         = Pushed $ signum a
    fromInteger a             = Pushed  a
    negate (Pushed a)         = Pushed $ negate a

instance Integral Stackable where
   quotRem   (Pushed a) (Pushed b) = (Pushed $ quot a b, Pushed $ rem a b)
   toInteger (Pushed a)            = a

instance Enum Stackable where
   succ (Pushed a)     = Pushed $ succ a
   pred (Pushed a)     = Pushed $ pred a
   toEnum a            = Pushed $ toInteger a
   fromEnum (Pushed a) = fromInteger a
   enumFrom (Pushed a) = map Pushed $ enumFrom a
   enumFromThen (Pushed a) (Pushed b) = map Pushed $ enumFromThen a b
   enumFromTo   (Pushed a) (Pushed b) = map Pushed $ enumFromTo a b
   enumFromThenTo (Pushed a) (Pushed b) (Pushed c) = map Pushed $ enumFromThenTo a b c

instance Real Stackable where
   toRational (Pushed a) = toRational a

instance Ord Stackable where
   compare (Pushed a) (Pushed b) = compare a b

instance Show Stackable where
    show (Pushed a) = show a
    show (Opname a) = "Opname " ++ show a
    show (Code a)   = "Code " ++ show a

type Dict  = Map.Map Word AST

data Interp = Interp{  stack::Stack
                      ,dict ::Dict
                    } deriving (Show) -- interpreter

interp:: Interp -> AST -> IO Interp
interp i (x:xs) = do i' <- procExp i x
                     interp i' xs
interp i [] = return i

procStack::Interp->(Stack->Stack)->IO Interp
procStack i f = return i{stack = f $ stack $ i}

procExp:: Interp -> Exp -> IO Interp
procExp i (Push lit)  = procStack i $(:) (Pushed lit)
procExp i (Name name) = procStack i $(:) (Opname name)
procExp i (Block ast) = procStack i $(:) (Code ast)
procExp i (Invoke "pop") = procStack i $ drop 1
procExp i@Interp {stack=(Code code):(Opname name):xs, dict = dict} (Invoke "def") 
    = return  i{stack=xs,dict = Map.insert name code dict }

procExp i (Invoke "add") = procStack i (\ (x1:x2:xs) -> (x1+x2):xs) 
procExp i (Invoke "sub") = procStack i (\(x1:x2:xs) -> (x2-x1):xs) 
procExp i (Invoke "mul") = procStack i (\(x1:x2:xs) -> (x1*x2):xs) 
procExp i (Invoke "mod") = procStack i (\(x1:x2:xs) -> ((abs x2) `mod` (abs x1)):xs) 
procExp i (Invoke "idiv")
    = procStack i (\(x1:x2:xs) ->  (signum x1)*(signum x2) *((abs x2) `div` (abs x1)):xs)
procExp i (Invoke "abs") = procStack i (\(x:xs) -> (abs x):xs) 
procExp i (Invoke "neg") = procStack i (\(x:xs) -> (negate x):xs) 

-- procExp i@Interp {stack=x:xs} (Invoke "dup") = return i{stack=x:x:xs} 
procExp i (Invoke "dup")   = procStack i (\ (x:xs)->(x:x:xs)) 
procExp i (Invoke "exch")  = procStack i (\ (x1:x2:xs)-> (x2:x1:xs)) 
procExp i (Invoke "clear") = procStack i (\ _ -> []) 
procExp i (Invoke "copy")  
    = procStack i (\ ((Pushed n):xs) -> (take (fromInteger n) xs)++xs )
procExp i (Invoke "count") = procStack i (\xs ->(Pushed $ toInteger $ length xs):xs )


procExp i@Interp {stack=xs} (Invoke "==")
    = mapM_ print xs >> return i{stack=[]} 
procExp i@Interp {stack=xs} (Invoke "pstack")
    = mapM_ print xs >> return i
procExp i (Invoke "roll")
    = procStack i (\((Pushed k):(Pushed n):xs)->roll (fromInteger n) (fromInteger k) xs)

procExp i@Interp{dict=dict} (Invoke name) = interp i (dict Map.! name)



roll::Int->Int->[a]->[a]
roll n k xs  = case k of
          k | k < 0           -> roll' n (abs k) xs
            | n < k           -> roll n (k `mod` n) xs
            | 1 < k && k <= n -> roll n (k-1) $ roll n 1 xs
            | k == 1          -> (drop 1 $ take n xs) ++ [head xs] ++ (drop n xs)
            | k == 0          -> xs
    where roll' n k xs = case k of
              k | n < k           -> roll' n (k `mod` n) xs
                | 1 < k && k <= n -> roll' n (k-1) $ roll' n 1 xs
                | k == 1          -> [last $ take n xs] ++ (take (n-1) xs) ++ (drop n xs)


{--
main
--}

initInterp = Interp{ stack=[], dict=Map.empty}

main :: IO ()
main = repl initInterp
repl :: Interp -> IO ()
repl i = do putStr ("phosh<"++(show $ length $ stack i)++"> ") 
            hFlush stdout
            src <- getLine `catch` (\e -> return ":q")
            case words src of
                (":q": _) -> return ()
                otherwise -> repl' i src 

repl'::Interp -> String -> IO ()
repl' i src = case (parse phorthProg "" src) of
                  Left err  -> do putStr "parse Error ar"
                                  print err
                  Right ast -> do i' <- interp i ast
                                  repl i'