gistfile1.hs

module Main where

import Data.Char
import Data.Word
import Control.Monad
import Control.Monad.State
import System.Environment

data Expr = Var String
          | Int Word8
          | Comp BinOpTag Expr Expr
          deriving Show

data BinOpTag = Sum | Prod | Subtr | Less | Greater | Equal
              deriving Show

data Stmt = Assign String Expr
          | Read String
          | Write Expr
          | If Expr Stmt Stmt
          | While Expr Stmt
          | Seq Stmt Stmt
          | Skip
          deriving Show

type BinOp a = a -> a -> a
type Env = [(String, Word8)]

lookupWord :: Env -> String -> Word8
lookupWord [] _ = 0
lookupWord ((var, val) : rest) name =
  case var == name of
    True -> val
    False -> lookupWord rest name

bind :: Env -> String -> Word8 -> Env
bind env var val = (var, val) : env

logicBinop :: (Word8 -> Word8 -> Bool) -> BinOp Word8
logicBinop f x1 x2 = case f x1 x2 of
  False -> 0
  True -> 1

binop :: BinOpTag -> BinOp Word8
binop tag = case tag of
  Sum -> (+)
  Prod -> (*)
  Subtr -> (-)
  Less -> logicBinop (<)
  Greater -> logicBinop (>)
  Equal -> logicBinop (==)

evalExpr :: Env -> Expr -> Word8
evalExpr env expr = case expr of
  Var var -> lookupWord env var
  Int val -> val
  Comp tag e1 e2 -> v1 `op` v2
    where op = binop tag
          v1 = evalExpr env e1
          v2 = evalExpr env e2

type IOInterpreter = StateT Env IO

lookupIO :: String -> IOInterpreter Word8
lookupIO var = do
  env <- get
  return $ lookupWord env var

bindIO :: String -> Word8 -> IOInterpreter ()
bindIO var val = do
  env <- get
  put $ bind env var val

evalExprIO :: Expr -> IOInterpreter Word8
evalExprIO expr = do
  env <- get
  return $ evalExpr env expr

interpretIO :: Stmt -> IOInterpreter ()
interpretIO s = case s of
  Assign var e -> do
    val <- evalExprIO e
    bindIO var val
  Read var -> do
    val <- lift $ readWordIO
    bindIO var val
  Write e -> do
    val <- evalExprIO e
    lift $ print val
  If e s1 s2 -> do
    val <- evalExprIO e
    case val of
      0 -> interpretIO s2
      _ -> interpretIO s1
  While e s1 -> do
    val <- evalExprIO e
    case val of
      0 -> return ()
      _ -> do
        interpretIO s1
        interpretIO s
  Skip -> return ()
  Seq s1 s2 -> do
    interpretIO s1
    interpretIO s2

readWordIO :: IO Word8
readWordIO = readLn

data Lexeme = LInteger Word8
            | LString String
            | LSemicolon
            | LAssign
            | LOpeningCurly
            | LClosingCurly
            | LPlus
            | LMult
            | LSubtr
            | LRead
            | LWrite
            | LIf
            | LElse
            | LWhile
            | LGreater
            | LLess
            | LEquals
            | LSkip
            deriving Show

keywords :: [(String, Lexeme)]
keywords =
  [("if", LIf),
   ("while", LWhile),
   ("read", LRead),
   ("write", LWrite),
   ("else", LElse),
   ("skip", LSkip)]

otherLexemes :: [(String, Lexeme)]
otherLexemes =
  [(":=", LAssign),
   (";", LSemicolon),
   ("{", LOpeningCurly),
   ("}", LClosingCurly),
   ("+", LPlus),
   ("*", LMult),
   ("-", LSubtr),
   (">", LGreater),
   ("<", LLess),
   ("==", LEquals)]

lexer :: String -> [Lexeme]
lexer [] = []
lexer s@(c:cs)
  | isAlpha c = let (str, rest) = span isAlpha s
                in case lookup str keywords of
                  Just l -> l : lexer rest
                  Nothing -> LString str : lexer rest
  | isSpace c = lexer cs
  | isDigit c = let (num, rest) = span isDigit s
                in LInteger (read num) : lexer rest
  | otherwise = let (str, rest) = span (not . isSpace) s
                in case lookup str otherLexemes of
                  Just l -> l : lexer rest
                  Nothing -> error $ "unknown lexeme " ++ str


parseExpr :: [Lexeme] -> Either String (Expr, [Lexeme])
parseExpr = parseExpr' []
  where parseExpr' stack ls = case ls of
          LInteger i : rest -> parseExpr' (Int i : stack) rest
          LString s : rest -> parseExpr' (Var s : stack) rest
          LPlus : rest -> combine Sum stack rest
          LMult : rest -> combine Prod stack rest
          LLess : rest -> combine Less stack rest
          LGreater : rest -> combine Greater stack rest
          LEquals : rest -> combine Equal stack rest
          _ -> case stack of
            [e] -> return (e, ls)
            _ -> Left $ "error in parsing expression around " ++ show (take 10 ls)
        combine tag stack rest = case stack of
          e1 : e2 : stack' -> parseExpr' (Comp tag e2 e1 : stack') rest
          _ -> Left $ "malformed exression around " ++ show (take 10 rest)

stmt1 = "n := 1 ; x := n n *"

match :: [Lexeme] -> Lexeme -> Either String [Lexeme]
match ls l = case ls of
  l : rest -> return rest
  _ -> Left $ "expected " ++ show l ++ " in " ++ show (take 10 ls)

parseStmt :: [Lexeme] -> Either String (Stmt, [Lexeme])
parseStmt ls = do
  (first, rest) <- case ls of
    LString var : LAssign : rest -> do
      (expr, rest) <- parseExpr rest
      return (Assign var expr, rest)
    LRead : LString var : rest ->
      return (Read var, rest)
    LWrite : rest -> do
      (expr, rest) <- parseExpr rest
      return (Write expr, rest)
    LIf : rest -> do
      (expr, rest) <- parseExpr rest
      rest <- match rest LOpeningCurly
      (s1, rest) <- parseStmt rest
      rest <- match rest LClosingCurly
      case rest of
        LElse : rest -> do
          rest <- match rest LOpeningCurly
          (s2, rest) <- parseStmt rest
          rest <- match rest LClosingCurly
          return (If expr s1 s2, rest)
        _ -> return (If expr s1 Skip, rest)
    LWhile : rest -> do
      (expr, rest) <- parseExpr rest
      rest <- match rest LOpeningCurly
      (s1, rest) <- parseStmt rest
      rest <- match rest LClosingCurly
      return (While expr s1, rest)
    _ -> Left $ "unexpected token around " ++ show (take 10 ls)
  case rest of
    LSemicolon : rest -> do
      (other, rest) <- parseStmt rest
      return (Seq first other, rest)
    _ -> return (first, rest)

interpretStringIO :: String -> IO ()
interpretStringIO s = do
  let ls = lexer s
      prog = parseStmt ls
  case prog of
    Left err -> putStrLn err
    Right (prog, ls) -> case ls of
      [] -> runStateT (interpretIO prog) [] >> return ()
      _ -> putStrLn $ "parse error: some lexemes remains " ++ show (take 10 ls)

main :: IO ()
main = do
  args <- getArgs
  case args of
    [name] -> do
      contents <- readFile name
      interpretStringIO contents
    _ ->
      putStrLn "provide a name of while with program"

gistfile2.txt

read n ;
k := 0 ;
curr := 0 ;
next := 1 ;
while k n < k n == + {
  t := next ;
  next := next curr + ;
  curr := t ;
  k := k 1 +
} ;
write curr