content: module Expr_Parser where
  
  import Control.Applicative hiding ((<|>))
  import Data.Char
  import Text.ParserCombinators.Parsec.Token
  import Text.ParserCombinators.Parsec
  
  data Language e =
    Lang { lLit    :: Integer -> e
         , lPlus   :: e -> e -> e
         , lLet    :: String -> e -> e -> e
         , lVar    :: String -> e
         , lNewref :: e -> e
         , lDeref  :: e -> e
         , lAssign :: e -> e -> e
         , lCatch  :: e -> e -> e
         , lPrint  :: String -> e
         }
  
  tok :: TokenParser st
  tok = makeTokenParser LanguageDef
    { commentStart    = "{-"
    , commentEnd      = "-}"
    , commentLine     = "--"
    , nestedComments  = True
    , identStart      = satisfy (\ c -> isAlpha c || c == '_')
    , identLetter     = satisfy (\ c -> isAlphaNum c || c == '_')
    , opStart         = satisfy (`elem` "+:=!;")
    , opLetter        = satisfy (`elem` "=")
    , reservedNames   = ["let", "new", "try", "catch", "print"]
    , reservedOpNames = ["+", ":=", "=", "!", ";"]
    , caseSensitive   = True
    }
  
  parseExpr :: Language e -> String -> Either ParseError e
  parseExpr lang = parse exprP ""
    where
  
      exprP = do
        e <- expr0
        eof
        return e
  
      expr0 = choice
        [ do reserved tok "let"
             x <- identifier tok
             reservedOp tok "="
             e1 <- expr2
             reservedOp tok ";"
             e2 <- expr0
             return $ lLet lang x e1 e2
        , do reserved tok "try"
             e1 <- expr0
             reserved tok "catch"
             e2 <- expr0
             return $ lCatch lang e1 e2
        , expr1
        ]
  
      expr1 = chainr1 expr2 (reservedOp tok ";" >> return (lLet lang "_"))
      expr2 = chainr1 expr3 (reservedOp tok ":=" >> return (lAssign lang))
      expr3 = chainl1 expr4 plusP
      expr4 = choice
        [ atomP
        , do reservedOp tok "!"
             e <- expr4
             return (lDeref lang e)
        , do reserved tok "new"
             e <- expr4
             return (lNewref lang e)
        , do reserved tok "print"
             m <- message
             return $ lPrint lang m
        ]
  
      atomP = choice
        [ lLit lang <$> integer tok
        , lVar lang <$> identifier tok
        , parens tok expr0
        ]
  
      plusP = reservedOp tok "+" >> return (lPlus lang)
  
      message = do -- reservedOp tok "'"
                   m <- stringLiteral tok
                   --reservedOp tok "'"
                   return m
  