gistfile1.hs

module LangParser(parseGrammar, Token(..), Result(..)) where

import Control.Applicative
import Control.Monad
--import Debug.Trace

data Token =
    Return              |
    Simple Char         |
    OctalConst String   |
    DecimalConst String |
    HexConst String     |
    NamedParam String   |
    Identifier String   |
    LexError String     |
    EOF
    deriving (Eq, Show)

data Op = ONop | OPlus | OMinus | OStar | OSlash deriving (Show, Eq)

instance Ord Op where
    compare a b
        | a == b        = EQ
        | a == ONop     = LT
        | b == ONop     = GT
        | a == OStar    = if b == OSlash then EQ else GT
        | a == OSlash   = if b == OStar then EQ else GT
        | otherwise     = LT

data Expr =
    EList Expr Expr |
    EAdd Expr Expr |
    ESub Expr Expr |
    EMul Expr Expr |
    EDiv Expr Expr |
    EIntConst Int
    deriving Show

data Stmt = SReturn [Expr] deriving Show
type Program = [Stmt]

data ParserState = ParserState { prog :: Program, exprStack :: [Expr], opStack :: [Op], rest :: [Token] } deriving Show

data Result a = Error Token | State a deriving Show

instance Monad Result where
    (Error e) >>= _     = Error e
    (State a) >>= f     = f a
    return              = State

instance Functor Result where
    fmap _ (Error t) = Error t
    fmap f (State a) = State (f a)

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

instance Alternative Result where
    empty = Error EOF
    Error _ <|> p = p
    State x <|> _ = State x

epsilon :: ParserState -> Result ParserState
epsilon = State

term :: Token -> ParserState -> Result ParserState
term t state@ParserState {rest = (x:xs)}
    | t == x    = State state{rest = xs}
    | otherwise = Error x 
term _ ParserState {rest = []} = Error EOF

termS :: Char -> ParserState -> Result ParserState
termS c = term (Simple c) 

termOp :: Char -> ParserState -> Result ParserState
termOp c = term (Simple c) >=> foldExpr (op c) >=> ret
     where 
     ret state = State state{opStack = op c : opStack state}
     op '+' = OPlus
     op '-' = OMinus
     op '*' = OStar
     op '/' = OSlash
     op _ = error "bad op"

termIntConst :: ParserState -> Result ParserState
termIntConst state@ParserState {rest = (DecimalConst x:xs)} = State state{exprStack = v : exprStack state, rest = xs}
    where v = EIntConst (read x)
termIntConst state@ParserState {rest = (HexConst x:xs)} = State state{exprStack = v : exprStack state, rest = xs}
    where v = EIntConst (read x)
termIntConst ParserState {rest = (x:_)} = Error x
termIntConst ParserState {rest = []} = Error EOF

foldExpr :: Op -> ParserState -> Result ParserState
foldExpr stop state = State state{exprStack = foldE exprTop opTop : exprTail, opStack = opTail}
    where
    (opTop, opTail) = span (> stop) (opStack state)
    (exprTop, exprTail) = splitAt (1 + length opTop) (exprStack state)
--    foldE a b | trace (show stop ++ " " ++ show a ++ " | " ++ show b) False  = undefined
    foldE (e:es) (OStar:ops) = EMul (foldE es ops) e
    foldE (e:es) (OSlash:ops) = EDiv (foldE es ops) e
    foldE (e:es) (OPlus:ops) = EAdd (foldE es ops) e
    foldE (e:es) (OMinus:ops) = ESub (foldE es ops) e
    foldE (e:_) [] = e
    foldE _ _ = error "bad foldE"

exprS :: ParserState -> Result ParserState
exprS = expr >=> foldExpr ONop

expr :: ParserState -> Result ParserState
expr s = (termIntConst >=> exprRest) s <|> (termS '(' >=> exprS >=> termS ')' >=> exprRest) s

exprRest :: ParserState -> Result ParserState
exprRest s = 
    (termOp '+' >=> expr) s <|> 
    (termOp '-' >=> expr) s <|> 
    (termOp '*' >=> expr) s <|> 
    (termOp '/' >=> expr) s <|> 
    epsilon s

retexprs :: ParserState -> Result ParserState
retexprs = exprS >=> exprList

exprList :: ParserState -> Result ParserState
exprList s = (termS ',' >=> retexprs >=> ret) s <|> epsilon s
    where 
    ret state@ParserState {exprStack = (e1:e2:es)} = State state{exprStack = EList e2 e1 : es}
    ret _ = error "2"

retStmt :: ParserState -> Result ParserState
retStmt = term Return >=> retexprs >=> termS ';' >=> ret
    where
    ret state@ParserState {exprStack = (e:es)} = State state{prog = SReturn (reverse $ unroll e []) : prog state, exprStack = es}
    ret _ = error "3"
    unroll :: Expr -> [Expr] -> [Expr]
    unroll (EList e1 e2) es = unroll e2 (e1:es)
    unroll e es = e:es

parseProgram :: ParserState -> Result ParserState
parseProgram = retStmt 

parseGrammar :: [Token] -> Result ParserState
parseGrammar st = parseProgram (ParserState [] [] [] st) 

Вход

1-2*3/4+5

[Return,DecimalConst "1",Simple '-',DecimalConst "2",Simple '*',DecimalConst "3",Simple '/',DecimalConst "4",Simple '+',DecimalConst "5",Simple ';']

PROG <- "return" EXPR ("," EXPR)* ";"
EXPR <- int | "(" EXPR ")" | EXPR "+" EXPR | EXPR "-" EXPR | EXPR "*" EXPR | EXPR "/" EXPR

Выход

State (ParserState {prog = [SReturn [EAdd (ESub (EIntConst 1) (EDiv (EMul (EIntConst 2) (EIntConst 3)) (EIntConst 4))) (EIntConst 5)]], exprStack = [], opStack = [], rest = []})

         +
     -       5
  1    /
     *   4
    2 3