# Language7

Seventh installment. This time I have added a facility for debug :) The task before you is to study the following

```
eval "10 1 [+] 1 2 [[i] swap dip] swap dip"
11 1 2
```

That is see the pattern of swap and dip used to get at the nth deep nest. Now try the below.

```
eval "10 1 [+] 1 2 [[i] ; 1 swap dip] swap dip"
```

As you can see `; intlabel`

acts as a way to check the state of stack at
that point. This also illustrates a kind of macro system called
immediate words or parsing words. We are effectively using the presence
of ‘;’ to intrepret the word *after* it in a different way. That means
that you can get at the execution word queue *before* evaluation of
terms. This can in effect allow us modify our abstract syntax tree
before the real execution.

Try this too.

```
eval "10 1 [+] 1 2 [[i] ; 1 swap dip] ; 2 swap dip"
```

Now your task is to come up with a sequence of words to evaluate

```
eval "10 1 [+] 1 2 3 4 5 ??"
11 1 2 3 4 5
```

Happy hacking :)

Here is the full code so far.

```
module Main where
import System.Environment
import System.IO
import Data.Char
import Debug.Trace
import Text.ParserCombinators.Parsec
type Word = String
type Env = [(String, [Nest])]
type Stack = [Nest]
initlib = unlines[
"[succ 1 +].",
"[pred 1 -].",
"[even? odd? not].",
"[double dup +].",
"[half dup odd? [succ 2 /] [2 /] if].",
"[if* 2 nwrap [!] swap dip i swap if].",
"[zero? 0 =?].",
"[split1 1 split].",
"[factorial [zero?] [pop 1] [dup pred factorial *] if*].",
"[: dup length swap [nwrap] dip zip [.] map pop]."
]
readLine :: String -> Nest
readLine input = case parse parseExpr "nest" input of
Left err -> error (show err)
Right q -> q
showStack = unwords . reverse . (map show)
eval :: String -> String
eval str = showStack $ bigStep [] e []
where Nested e = readLine (initlib ++ " " ++ str)
evalFile file = do
str <- readFile file
return $ eval str
main = do
fn <- getArgs
case fn of
[] -> error "Need file.nst to evaluate."
(x:xs) -> do res <- evalFile $ fn !! 0
putStrLn (show res)
parseExpr = do
x <- many parseSingle
return $ Nested x
parseSingle :: Parser Nest
parseSingle = do
spaces
x <- (try parseFloat) <|>
(try parseInt) <|>
(try parseNegInt) <|>
(try parseBool) <|>
(try parseString) <|>
(try parseWord) <|>
(try parseNest)
spaces
return x
parseNest :: Parser Nest
parseNest = do
char '['
e <- parseExpr
char ']'
return e
parseFloat :: Parser Nest
parseFloat = do
I i <- parseInt
char '.'
I j <- parseInt
res <- return $ (show i) ++ ['.'] ++ (show j)
return $ F (read res)
parseNegInt :: Parser Nest
parseNegInt = do
char '-'
i <- many1 digit
return $ I $ -1 * (read i)
parseInt :: Parser Nest
parseInt = do
i <- many1 digit
return $ I (read i)
parseWord :: Parser Nest
parseWord = do
w <- many1 (noneOf " nrt[]")
return $ W w
parseBool :: Parser Nest
parseBool = do
(x:xs) <- string "true" <|> string "false"
return $ B (read (toUpper x : xs))
parseString :: Parser Nest
parseString = do
char '''
s <- many (noneOf "'")
char '''
return $ S s
{-
<digit> ::= 0..9
<num> ::= <digit>
| <digit><num>
<letter> ::= a..z | + | - | * | / | < | > | = | .
<char> ::= <letter>
| <digit>
<word> ::= <letter>
| <word> <char>
<nest> ::= <num>
| <word>
| [ <nest>* ]
<expr> ::= <nest>*
-}
data Nest = W String
| I Int
| F Float
| B Bool
| S String
| Nested [Nest]
deriving (Eq)
instance Show Nest where
show (W s) = s
show (S s) = (show s)
show (I i) = (show i)
show (F f) = (show f)
show (B b) = (show b)
show (Nested b) = "[" ++ (unwords (map show b)) ++ "]"
bigStep :: Env -> [Nest] -> Stack -> Stack
bigStep _ [] r = r
bigStep env (Nested n: xs) ys = bigStep env xs (Nested n: ys)
bigStep env (I i: xs) ys = bigStep env xs (I i: ys)
bigStep env (F i: xs) ys = bigStep env xs (F i: ys)
bigStep env (B i: xs) ys = bigStep env xs (B i: ys)
bigStep env (S i: xs) ys = bigStep env xs (S i: ys)
bigStep env (W "+": xs) (I i: I j: ys) = bigStep env xs (I (j+i): ys)
bigStep env (W "*": xs) (I i: I j: ys) = bigStep env xs (I (j*i): ys)
bigStep env (W "-": xs) (I i: I j: ys) = bigStep env xs (I (j-i): ys)
bigStep env (W "/": xs) (I i: I j: ys) = bigStep env xs (F ((fromIntegral j)/(fromIntegral i)): ys)
bigStep env (W ">": xs) (I i: I j: ys) = bigStep env xs (B (j > i): ys)
bigStep env (W "<": xs) (I i: I j: ys) = bigStep env xs (B (j < i): ys)
bigStep env (W "=?": xs) (I i: I j: ys) = bigStep env xs (B (j == i): ys)
bigStep env (W "=?": xs) (S i: S j: ys) = bigStep env xs (B (j == i): ys)
bigStep env (W "=?": xs) (B i: B j: ys) = bigStep env xs (B (j == i): ys)
bigStep env (W "=?": xs) (F i: F j: ys) = bigStep env xs (B (j == i): ys)
bigStep env (W "=?": xs) (Nested i: Nested j: ys) = bigStep env xs (B (j == i): ys)
bigStep env (W "odd?": xs) (I i: ys) = bigStep env xs (B (odd i): ys)
bigStep env (W "and": xs) (B a:B b:ys) = bigStep env xs (B (b && a):ys)
bigStep env (W "or": xs) (B a:B b:ys) = bigStep env xs (B (b || a):ys)
bigStep env (W "not": xs) (B a:ys) = bigStep env xs (B (not a):ys)
bigStep env (W "dup": xs) (y:ys) = bigStep env xs (y:y:ys)
bigStep env (W "swap": xs) (y:y':ys) = bigStep env xs (y':y:ys)
bigStep env (W "pop": xs) (y:ys) = bigStep env xs ys
bigStep env (W "cons": xs) (Nested y':y:ys) = bigStep env xs (Nested (y:y'):ys)
bigStep env (W "concat": xs) (Nested y':Nested y:ys) = bigStep env xs (Nested (y ++ y'):ys)
bigStep env (W "empty?": xs) (Nested y:ys) = bigStep env xs (B (length y == 0):ys)
bigStep env (W "reverse": xs) (Nested y:ys) = bigStep env xs (Nested (reverse y): ys)
bigStep env (W "split": xs) (I i:Nested nys:ys) = bigStep env xs (Nested arr1:(Nested arr2): ys)
where (arr2,arr1) = splitAt i nys
bigStep env (W "nwrap": xs) (I i:ys) = bigStep env xs ((Nested lst) : rest)
where lst = take i ys
rest = drop i ys
bigStep env (W "i":xs) (Nested v:ys) = bigStep env (v ++ xs) ys
bigStep env (W "!":xs) ys = bigStep env xs $ (head res):(tail ys)
where res = bigStep env (W "i":xs) ys
bigStep env (W "dip":xs) (y:ys) = bigStep env xs $ y:lst
where lst = bigStep env [W "i"] ys
bigStep env (W "if":xs) (Nested v2:Nested v1:B c:ys) = bigStep env (res ++ xs) ys
where res = if c then v1 else v2
bigStep env (W "length":xs) (Nested v:ys) = bigStep env xs (I (length v) :ys)
bigStep env (W ".":xs) (Nested ((W w):as):ys) = bigStep ((w,as):env) xs ys
bigStep env (W ";":I x:xs) ys = bigStep env xs (trace ("["++(show x) ++"] Stack was: " ++ (showStack ys) ++ "n") ys)
bigStep env (W "{":xs) ys = bigStep (("{",[]):env) xs ys
bigStep env (W "}":xs) ys = bigStep myenv xs ys
where myenv = tail $ dropWhile (/= ("{", [])) env
bigStep env (W "(":xs) ys = bigStep env xs (W "(":ys)
bigStep env (W ")":xs) ys = bigStep env xs (Nested (reverse arr): (tail st))
where (arr,st) = span (/= W "(") ys
bigStep env (W x :xs) ys = bigStep env (def ++ xs) ys
where def = case lookup x env of
Nothing -> error ("Definition not found or is not applicable for word {" ++ x ++ "} with stack " ++ (showStack ys))
Just x -> x
```