pars.hs

import Text.Parsec(char, digit, letter, alphaNum, spaces, parse, string)
--import Text.Parsec.Char
--import Text.ParserCombinators.Parsec(try)
import Text.Parsec.Combinator
import Text.Parsec.String(Parser)
import Text.Parsec.Token
import Text.Parsec.Expr(Operator, Operator(Infix, Prefix), Assoc(AssocLeft), buildExpressionParser)
import Control.Applicative(Applicative, many, (<$>), (<*>), (<|>), (<*), (<$), (*>))
import Control.Monad(join)
--import Data.Char
import Data.Functor.Identity(Identity)
import Data.Maybe(fromMaybe, fromJust, isJust)
import qualified Data.Map as M

infixr 5 <:>
(<:>) :: Applicative f => f a -> f [a] -> f [a] 
a <:> b = (:) <$> a <*> b

--pure :: a -> f a
--Lift a value.

--(<*>) :: f (a -> b) -> f a -> f b infixl 4
--Sequential application.

--(*>) :: f a -> f b -> f b infixl 4
--Sequence actions, discarding the value of the first argument.

--(<*) :: f a -> f b -> f a infixl 4
--Sequence actions, discarding the value of the second argument.

--(<|>) :: f a -> f a -> f a infixl 3
--An associative binary operation

-- (<$>) :: Functor f => (a -> b) -> f a -> f b infixl 4 <$>

main :: IO()
main = 
	print $ interpret example

number :: Parser Int
number = read <$> many1 digit

negative :: Parser Int
negative = read <$> char '-' <:> many1 digit

type CmdName = String

data Expression = Val   Value
                | Var   String
                | Plus  Expression Expression
                | Minus Expression Expression
                | Mult  Expression Expression
                | Div   Expression Expression
                | Not  Expression Expression
                | And  Expression Expression
                | Or   Expression Expression
                | Cmd CmdName [String]
                  deriving (Show)

data Statement = Assignment String Expression
               | If Expression Statement (Maybe Statement)
                deriving (Show)

type VarTable = M.Map String Value

data Value = VBool Bool
           | VFloat Float
           deriving (Show)

class Convert a where
    toValue :: a -> Value
    fromValue :: Value -> a

instance Convert Float where
    toValue = VFloat
    fromValue (VFloat a) = a

instance Convert Bool where
    toValue = VBool
    fromValue (VBool a) = a

eval :: VarTable -> Expression -> Value -- if the variable does not exist then an error occurs (used to be -> maybe Value)
eval vt e = case e of (Val   v)   -> v
                      (Var   v)   -> fromJust $ M.lookup v vt
                      (Plus  a b) -> liftValue (+) (eval vt a) (eval vt b)
                      (Minus a b) -> liftValue (-) (eval vt a) (eval vt b)
                      (Mult  a b) -> liftValue (*) (eval vt a) (eval vt b)
                      (Div   a b) -> liftValue div (eval vt a) (eval vt b)
  where liftValue f v1 v2 = toValue $ f (fromValue v1) (fromValue v2)

makeStatement :: Statement -> VarTable -> VarTable
makeStatement (If e st mst) vt
  | fromValue $ eval vt e    = makeStatement st vt
  | isJust mst               = makeStatement (fromJust mst) vt
  | otherwise                = vt
makeStatement (Assignment v e) vt = insert v vt $ eval vt e
    where insert k = flip (M.insert k)

run :: [Statement] -> VarTable
run = run' M.empty
    where run' = foldl $ flip makeStatement
-- foldl :: (a -> b -> a) -> a -> [b] -> a
-- join :: Monad m => m (m a) -> m a

assignment :: Parser Statement
assignment = Assignment <$> variable <*> (stringInSpaces "=" *> expression)

parseIf :: Parser Statement
parseIf = If <$> (stringInSpaces "if " *> expression) <*> (stringInSpaces "then " *> statement) <*> optionMaybe (stringInSpaces "else " *> statement)

stringInSpaces :: String -> Parser String
stringInSpaces str = spaces *> string str <* spaces

statement :: Parser Statement
statement = parseIf <|> assignment

interpret :: String -> Maybe VarTable
interpret s = case parse (many1 statement) "error" s of 
                Left  _ -> Nothing
                Right p -> Just $ run   p

-- Both of our operators have the same priority
expressionTable :: [[Operator String () Identity Expression]]
expressionTable =  [[binary "*" Mult, binary "/" Div], [binary "+" Plus, binary "-" Minus]]
        where binary name f = Infix (f <$ stringInSpaces name) AssocLeft
              prefix name f = Prefix (f <$ stringInSpaces name)

expression :: Parser Expression
expression = buildExpressionParser expressionTable other
    where other = var <|> val
          var  = Var <$> variable
          val  = Val <$> toValue <$> realToFrac <$> float
variable :: Parser String
variable = (spaces *> char '$' *>) $ letter <:> many alphaNum

example :: String
example = "$a = 2 * 3 + 1\n$c = 14\nif 0 then $b = 2"