TCL clone

AST.hs

module AST where

type Program = [Command]
data Command = Command Expr [Expr]
data Expr = Str Ident
          | Num Integer
          | List [Expr]

type Ident = String

gistfile1.txt

-- runFile "test.tlc"

module TLC where

import AST
import TLCParser
import Control.Monad
import Control.Arrow
import Control.Applicative hiding (empty)
import Data.Map
import Prelude hiding (lookup)

{-
set var
set var value
proc f args body
puts str
gets str

set y Hello
proc foo {x} {
    puts [set y]
    puts [set x]
}

proc bar {x y z} {return [x] hello}
set [bar] world

callPhone [phone [set simon]] 3

-}

data Env = Env { vtable :: Map Expr Expr
               , ftable :: Map Expr ([String], Expr)
               }
         deriving Show

initialEnv = Env { vtable = empty 
                 , ftable = empty }

newtype TLC a = TLC { runTLC :: Env -> Either String (a, Env) }

instance Monad TLC where
  return x = TLC $ \env -> Right (x, env)
  ma >>= f = TLC $ \env -> case runTLC ma env of
                             Left s -> Left s
                             Right (x, env') -> let mb = f x
                                                in runTLC mb env'
  fail errMsg = TLC $ \env -> Left errMsg

  -- Before we added error handling (Either String):
  -- ma >>= f = TLC $ \env -> let (x, env') = runTLC ma env
  --                              mb = f x
  --                          in runTLC mb env'

  -- (TLC ma) >>= f = TLC $ \env -> let (x, env') = ma env
  --                                    (TLC mb) = f x
  --                                in mb env'

instance Functor TLC where
    fmap = liftM

instance Applicative TLC where
    pure  = return
    (<*>) = ap

get = TLC $ \env -> Right (env, env)
put env = TLC $ \_ -> Right ((), env)
modify f = do
  x <- get
  put (f x)

scope :: Env -> Expr -> TLC Expr
scope subEnv bodyExpr = TLC $ \env -> runTLC (evalExpr bodyExpr) subEnv

evalExpr :: Expr -> TLC Expr
evalExpr (Str str) = return (Str str)
evalExpr (Num num) = return (Num num)
evalExpr (List exps) = liftM List $ mapM evalExpr exps
-- evalExpr (List exprs) = do
--   exprs' <- mapM evalExpr exprs
--   return $ List exprs'
--evalExpr (List exps) = List <$> mapM evalExpr exps
evalExpr (Exec cmd) = evalCommand cmd

evalBuiltinCommand :: Expr -> [Expr] -> TLC Expr
-- evalBuiltinCommand (Str "set") [exp] = do exp' <- evalExpr exp
--                                           return exp'
evalBuiltinCommand (Str "set") [exp] = evalExpr exp
evalBuiltinCommand (Str "set") [var, value] = do
  var' <- evalExpr var
  value' <- evalExpr value
  modify (\env -> env { vtable = insert var' value' (vtable env) })
  return value'

evalBuiltinCommand (Str "proc") [args, body] = fail "Procs not working yet!"

evalBuiltinCommand foo bars = fail $ "WTF: " ++ show foo ++ ", " ++ show bars

isBuiltin (Str name) = name `elem` ["set", "proc"]

evalCommand :: Command -> TLC Expr
evalCommand (Command cmdExpr argsExprs) = do
  env <- get
  cmdExpr' <- evalExpr cmdExpr
  if isBuiltin cmdExpr'
    then evalBuiltinCommand cmdExpr' argsExprs
    else case lookup cmdExpr' (ftable env) of
    Just (args, bodyExpr) -> do argsResult <- mapM evalExpr argsExprs
                               -- TODO: Check that args and argsResult have same size
                                let vtable' = fromList $ zipWith (\str exp -> (Str str, exp)) args argsResult
                                --let vtable' = fromList $ zipWith (first Str) args argsResult
                                    env'    = Env vtable' (ftable env)
                                retval <- scope env' bodyExpr
                                return retval
    Nothing -> fail $ "Command " ++ show cmdExpr' ++ " not recognized"

evalProgram :: Program -> TLC ()
evalProgram = mapM_ evalCommand
--evalProgram cmds = (mapM_ evalCmd) cmds

run :: Program -> Either String Env
run program = liftM snd $ runTLC (evalProgram program) initialEnv
-- run program = case runTLC (evalProgram program) initialEnv of
--                 Left s -> Left s
--                 Right tup -> snd tup

--runFile :: FilePath -> IO (Either String Env)
runFile fname = do
  ast <- parseFile fname
  case ast of
    Left err  -> putStrLn $ "Parse error: " ++ err
    Right pgm -> putStrLn $ show (run pgm)


-- example_ma :: TLC Int
-- example_ma = TLC $ \env -> (5, env)

gistfile2.txt

set x 42
set y 10
proc foo {} {set z 0}

Parsing numbers

foldl (\ result digit -> result * 10 + digit) 0 $ map (\c -> ord c - ord '0') "123"

TLCParser.hs

module TLCParser where

import AST
import Data.Char
import Control.Applicative hiding (many)
import Text.ParserCombinators.ReadP

type Parser = ReadP

program :: Parser Program
program =  command `sepBy1` (symbol' "\n")

command :: Parser Command
command = do
  name <- expr
  args <- many1 expr
  return $ Command name args

expr :: Parser Expr
expr = do s <- str
          return (Str s)
       +++
       do n <- num
          return (Num n)
       +++
       do symbol' "{"
          es <- many expr
          symbol' "}"
          return $ List es
       +++
       do symbol' "["
          cmd <- command
          symbol' "]"
          return $ Exec cmd

str :: Parser String
str = token' $ do string "\""
                  s <- many (satisfy (\c -> isPrint c && c /= '"'))
                  string "\""
                  return s
      +++ ident

ident = token' $ do
  c  <- satisfy (\c -> isSpecial c && not (isDigit c))
  cs <- munch isSpecial
  return (c:cs)

isSpecial :: Char -> Bool
isSpecial c = not (isSpace c) &&  c `notElem` "[]{}$\""

num :: Parser Integer
num = token' $ fmap read (munch1 isDigit)

token' :: Parser a -> Parser a
token' p = p <* munch isSpace'
  where isSpace' c = c == ' ' || c == '\t'

symbol' :: String -> Parser String
symbol' s = token' (string s)

parse, parseEof :: Parser a -> String -> [(a,String)]
parse p = readP_to_S p
parseEof p = readP_to_S (p <* skipSpaces <* eof)

parseFile :: FilePath -> IO (Either String Program)
parseFile fname = do
  content <- readFile fname
  return $ case parseEof program content of
    [(ast, "")] -> Right ast
    []          -> Left "Invalid parse"
    _           -> Left "Ambiguous"