MyParser.hs

Main.hs

module Main where
import Prelude hiding (getContents, putStrLn) -- версия из Prelude не держит UTF-8 :(
import System.IO.UTF8 (getContents, putStrLn)
import MyParser
import qualified Data.Map as M

main = do 
    x <- getContents 
    let a = apply lang x
        output = case a of 
            Left (s, l, p, v) -> show l ++ ";" ++ show p ++ ";" ++ s
            Right ((a, l, p, v), b) -> if a == "" then "good\n" ++ dump_vars v else
                show l ++ ";" ++ show p ++ ";trash at the end" 
        dump_vars = unlines . map (\(var, val) -> var ++ ";" ++ show val) . M.toAscList
    putStrLn output 

MyParser.hs

module MyParser
    where
import Char
import qualified Data.Map as M

type VariablesMap = M.Map String Float
type StringWithPosition = (String, Int, Int, VariablesMap)
newtype Parser a = Parser (StringWithPosition -> Either StringWithPosition (StringWithPosition, a))

instance Monad Parser where
    return a = Parser $ \cs -> Right (cs, a)
    Parser p >>= f  = Parser $ \cs ->
        case p cs of 
            Left s -> Left s
            Right (cs', a) -> let Parser n = f a in n cs'
    fail str = Parser $ \(cs, s, e, v) -> Left (str, s, max s e, v)

class Monad m => MonadParser m where
    (<+>) :: m String -> m String -> m String
    (<|>) :: m a -> m a -> m a

instance MonadParser Parser where
    p <|> q = Parser $ \cs -> case parse p cs of 
        Right a -> Right a
        Left (s, l, p, v) -> case parse q cs of
            Right ((s', l', p', v'), a) -> Right ((s', l', max p' p, v'), a)
            Left (s', l', p', v') -> Left(s', l', max p' p, v')
    p <+> q = do { a <- p; b <- q; return (a ++ b) }

parse (Parser p) = p

item :: Parser Char 
item = Parser $ \(cs, s, e, v) -> case cs of 
    "" -> Left ("EOF", s, max e s, v)
    (c:cs) -> Right ((cs, s + 1, e, v), c)

read_variable :: String -> Parser Float
read_variable var = Parser $ \(cs, s, e, v) -> case M.lookup var v of
    Nothing -> Left ("unknown variable;" ++ var, s, e, v)
    Just x -> Right ((cs, s, e, v), x)
    
write_variable :: String -> Float -> Parser Float
write_variable var val = Parser $ \(cs, s, e, v) -> Right ((cs, s, e, M.insert var val v), val) 

-- sat is a shorthand from satisfy 
sat :: (Char -> Bool) -> Parser Char
sat p = do {c <- item; if p c then return c else fail ("unexpected;" ++ (show c))}

char :: Char -> Parser Char 
char c = sat (c ==)

string :: String -> Parser String 
string "" = return "" 
string (c:cs) = do {char c; string cs; return (c:cs)}

optional :: Parser a -> Parser [a]
optional p = do {a <- p; return [a]} <|> return []

many :: Parser a -> Parser [a] 
many p = many1 p <|> return [] 
many1 :: Parser a -> Parser [a] 
many1 p = do {a <- p; as <- many p; return (a:as)}

sepby :: Parser a -> Parser b -> Parser [a] 
p `sepby` sep = (p `sepby1` sep) <|> return [] 
sepby1 :: Parser a -> Parser b -> Parser [a] 
p `sepby1` sep = do a <- p 
                    as <- many (do {sep; p}) 
                    return (a:as) 
                    
chainl :: Parser a -> Parser (a -> a -> a) -> a -> Parser a 
chainl p op a = (p `chainl1` op) <|> return a 
chainl1 :: Parser a -> Parser (a -> a -> a) -> Parser a 
p `chainl1` op = do {a <- p; rest a} 
                 where 
                     rest a = (do f <- op 
                                  b <- p 
                                  rest (f a b)) 
                              <|> return a 

space :: Parser String 
space = many (sat isSpace)

token :: Parser a -> Parser a 
token p = do {a <- p; space; return a}

symb :: String -> Parser String 
symb cs = token (string cs)

apply :: Parser a -> String -> Either StringWithPosition (StringWithPosition, a) 
apply p x = parse (do {space; p}) (x, 0, 0, M.empty)

---- Grammar
rvalue :: Parser Float 
addop :: Parser (Float -> Float -> Float)
mulop :: Parser (Float -> Float -> Float)
logop :: Parser (Float -> Float -> Float)
float_number :: Parser Float
float_number_with_minus :: Parser Float

lang = token (string "Программа") <|> fail "begin" >>
        definitions >> execlines >>
        token (string "Конец") <|> fail "end"

definitions = token(definition) `sepby1` (symb ";")
definition  = token execute_change_insert <|> fail "exechains" >>
                symb ":" <|> fail "definition :" >>
                many1 (token float_number_with_minus ) <|> fail "definition float_numbers" >>
                token first_second_third <|> fail "123"
execute_change_insert = string "Выполнить" <|> string "Изменить" <|> string "Вставить"
first_second_third    = string "Первое"    <|> string "Второе"   <|> string "Третье"

execlines = many1 $ token execline
execline = do
    labels <|> fail "labels"
    symb ":" <|> fail "label"
    var <- lvalue <|> fail "lvalue"
    token (symb "=") <|> fail "lvalue="
    rval <- rvalue
    write_variable var rval
lvalue = token variable_name
labels = many1 $ token integer_number

rvalue    = term      `chainl1` addop
term      = factor    `chainl1` mulop 
factor    = functions `chainl1` logop
value     = float_number <|> integer_number <|> variable
digits    = many1 $ sat isDigit
addop     = do {symb "+"; return (+)} <|> do {symb "-"; return (-)} 
mulop     = do {symb "*"; return (*)} <|> do {symb "/"; return (/)}
logop     = do {symb "|"; return nor} <|> do {symb "&"; return nand}

functions = do {x <- many( token function ); y <- value; return $ foldr (\x y -> x y) y x}
function  = do {string "sin"; return sin } <|>  do {string "cos"; return cos} <|>
                do {string "tan"; return tan} <|> do {string "-"; return (0-)} <|> 
                do {string "!"; return nnot}

float_number   = do { a <- token (digits <+> symb "." <+> digits); return $ read a }
float_number_with_minus = do
    a <- token $ optional(char '-') <+> digits <+> string "." <+> digits
    return $ read a
integer_number = do { a <- token digits; return $ read a }
variable_name = many1 (sat isRussianAlpha) <+> many (sat isDigitOrAlpha)
variable      = do { a <- token variable_name; read_variable a }

----- 
isRussianAlpha :: Char -> Bool
isRussianAlpha c = (( c >= 'а' ) && ( c <= 'я' )) || (( c >= 'А' ) && ( c <= 'Я' )) ||
                   c == 'ё' || c == 'Ё'
isDigitOrAlpha :: Char -> Bool
isDigitOrAlpha c = isDigit c || isRussianAlpha c

----- Logical functions for floats
nor :: Float -> Float -> Float
nand :: Float -> Float -> Float
nnot :: Float -> Float

nor 0 0     = 0
nor _ _     = 1

nand 0 _    = 0
nand _ 0    = 0
nand _ _    = 1

nnot 0      = 1
nnot _      = 0