import IO
import Char
import List
import Bits
import Data.IORef
import System ( getArgs )

prec x = case x of
    NumericNegate -> 13; BinaryNegate -> 13; LogicalNegate -> 13; Hd -> 13; Tl -> 13; Deref -> 13
    Mul -> 12; Div -> 12; Mod -> 12
    Add -> 11; Sub -> 11
    Gt -> 10; Lt -> 10; Le -> 10; Ge -> 10
    Concat -> 9
    Cons -> 8; Append -> 8
    Equals -> 7; NotEquals -> 7
    Or -> 6
    And -> 5
    LogicalAnd -> 4
    LogicalOr -> 3
    RefAssign -> 2
    Hook -> 1
    _ -> error $ "can't get the precedence of " ++ (show x)

type LangInt = Integer
type LangFloat = Double
type VariableName = String

data Token = Num LangInt | FNum LangFloat | Identifier String | StringLiteral String
           | Add | Sub| Mul | Div | Mod | Lt | Gt | Le | Ge | Equals | NotEquals 
           | And | Or | LogicalAnd | LogicalOr | Cons | Append | Concat | RefAssign
           | BinaryNegate | LogicalNegate | Hd | Tl
           | LCurly | RCurly | LParen | RParen | Lb | Rb
           | Semi | Comma | Colon | Define | Hook
           | If | Then | Else | Fn | TrueT | FalseT | Null | Switch | Case | Default | Nil | Do | While
           | Catch | Throw | Future | Lazy | Ref
           | NumericNegate | Deref -- these aren't really tokens, they are just used by the parser
           deriving (Show,Eq)

data Expr = Constant Value | Variable VariableName
          | BinaryExpr Expr Token Expr  -- lhs, op, rhs
          | UnaryExpr Token Expr
          | LambdaExpr [VariableName] Expr  -- [bound vars] expr
          | IfExpr Expr Expr Expr  -- test iftrue iffalse
          | CallExpr Expr [Expr] -- value, args
          | CaseExpr Expr [(Expr,Expr)] Expr -- value, [key/value pairs], default
          | ListExpr [Expr] | SequenceExpr [Stmnt]
          | ExceptionHandlerExpr Expr VariableName Expr | ThrowExpr Expr | FutureExpr Expr | LazyExpr Expr
          | RefExpr Expr
          deriving Show

data Stmnt = ExprStmnt Expr | DefineStmnt VariableName Expr | LoopStmnt Expr Expr deriving Show
data Lambda = ExprLambda [VariableName] Expr Scope | NativeLambda ([Value] -> EvalFunc Value)
data Value = StringValue String | IntValue LangInt | FloatValue LangFloat | BoolValue Bool | NullValue | ListValue [Value] 
           | LambdaValue Lambda | RefValue (IORef Value)
           
        
instance Show Value where
    show (StringValue s) = "StringValue:"++s
    show (IntValue i) = "IntValue:"++(show i)
    show (BoolValue b) = "BoolValue:"++(show b)
    show (NullValue) = "NullValue"
    show (ListValue l) = show l
    show (LambdaValue l) = show l
    show (RefValue _) = "RefValue"

instance Show Lambda where
    show (ExprLambda _ _ _) = "Lambda"
    show (NativeLambda _) = "Native Lambda"

data Scope = ScopeVal VariableName Value Scope | ScopeTop

rightAssoc Cons = True
rightAssoc RefAssign = True
rightAssoc _ = False

data ParserLocation = RowCol Integer Integer | Row Integer | Eof deriving Show 
data ParserResult a = Success a | Fail String ParserLocation deriving Show
data Parser a b = Parser([(a,ParserLocation)] -> ParserResult([(a,ParserLocation)],b))

instance Monad (Parser a) where
    return x = Parser(\cs -> Success(cs,x))
    Parser p >>= f = Parser $ \cs -> 
        case p cs of
            Success (cs2,r) -> p2 cs2 where Parser p2 = f r
            Fail s l -> Fail s l
    fail s = parseFail s

parseIsEof = Parser $ \cs -> Success(cs,null cs)
parseLocation = Parser $ \cs -> case cs of
        (e:_) -> Success(cs,snd e)
        _ -> Success(cs,Eof)

parseFail s = do
    l <- parseLocation
    Parser $ \cs -> Fail s l

Parser p `orParse` Parser q = Parser $ \cs -> 
        case p cs of
            Fail _ _ -> q cs
            Success x-> Success x

noParse = parseFail "parse failed"

parseItem f = parseItemDesc f "another token"
parseItemDesc f desc = Parser $ \cs ->
    case cs of
        ((c,l):cs) ->
            if f c then Success(cs,c) 
            else Fail ("Got " ++ (show c) ++ " where " ++ desc ++ " was expected") l
        [] -> Fail ("Got Eof where " ++ desc ++ " was expected") Eof


parseThis c = parseItemDesc (==c) (show c)

parseAny :: Show a => Parser a a
parseAny = parseItem $ const True

parse1Plus p = do
    i <- p
    rest <- parse1Plus p `orParse` return []
    return (i:rest)

parse0Plus p = parse1Plus p `orParse` return []

parse1Sep p sep = do
    i <- p
    rest <- parse1Plus(do {sep; p}) `orParse` return []
    return (i:rest)

parse0Sep p sep = parse1Sep p sep `orParse` return []

parse0PlusUntil p s = do
    do { i <- s; return []; } `orParse` do
        i <- p
        rest <- parse0PlusUntil p s
        return (i:rest)

lexDigit = parseItem isDigit

lexHexDigit = parseItem isHexDigit

lexDecValue = do 
    cs <- parse1Plus lexDigit
    return $ Num $ foldl (\a b -> a*10+(fromIntegral $ digitToInt b)) 0 cs

lexHexValue = do
    parseThis '0'
    parseThis 'x' `orParse` parseThis 'X'
    cs <- parse1Plus lexHexDigit
    return $ Num $ foldl (\a b -> a*16+(fromIntegral $ digitToInt b)) 0 cs

lexFloatValue = do
    l <- parse0Plus lexDigit
    parseThis '.'
    r <- parse1Plus lexDigit
    return $ FNum $ 
        fromIntegral(foldl (\a b -> a*10+(fromIntegral $ digitToInt b)) 0 l) + 
        (foldr (\a b -> b/10.0+fromIntegral(digitToInt a)/10.0) 0.0 r)
    
lexKeywordOrIdentifier = do
    f <- parseItem isAlpha
    r <- parse0Plus (parseItem isAlphaNum)
    return $ case (f:r) of
        "if" -> If; "else" -> Else; "then" -> Then; "fn" -> Fn; "true" -> TrueT; "false" -> FalseT; "null" -> Null 
        "case" -> Case; "switch" -> Switch; "default" -> Default; "hd" -> Hd; "tl" -> Tl; "nil" -> Nil
        "catch" -> Catch; "throw" -> Throw; "future" -> Future; "lazy" -> Lazy; "while" -> While; "do" -> Do; "ref" -> Ref
        s -> Identifier (f:r)


lexStringLiteral =
    do
        parseThis '"'
        s <- lexStringLiteral'
        return $ StringLiteral s
    where
        lexStringLiteral' =
            do {
                parseThis '"';
                return []
            } `orParse` do {
                c <- parseThis '\\';
                c2 <- do {
                    c1 <- parseItem $ \c -> c >= '0' && c <= '4';
                    c2 <- parseItem $ \c -> c >= '0' && c <= '8';
                    c3 <- parseItem $ \c -> c >= '0' && c <= '8';
                    return $ chr $ foldl (\a b -> a*8+b) 0 $ map digitToInt [c1,c2,c3];
                } `orParse` do { 
                    c <- parseAny;
                    return $ case c of 
                        'n' -> '\n'; 't' -> '\t'; '\\' -> '\\'
                        'a' -> '\a'; 'b' -> '\b'; 'f' -> '\f'
                        'r' -> '\r'; 'v' -> '\v'; '"' -> '"'
                        '0' -> '\0'
                        _ -> c
                };
                rest <- lexStringLiteral';
                return (c2:rest)
            } `orParse` do {
                c <- parseAny;
                rest <- lexStringLiteral';
                return (c:rest)
            }

lexComment = do
    parseThis '/'
    c <- parseItem (\x -> x=='*' || x=='/')
    case c of
        '*' -> parse0PlusUntil parseAny (do { parseThis '*'; parseThis '/' })
        '/' -> parse0PlusUntil parseAny (do { parseThis '\n'; })

lexSymbol = do
    c <- parseAny
    case c of
        '=' -> do { parseThis '='; return Equals; } `orParse` (return Define)
        '>' -> do { parseThis '='; return Ge; } `orParse` (return Gt)
        '<' -> do { parseThis '='; return Le; } `orParse` (return Lt)
        '&' -> do { parseThis '&'; return LogicalAnd; } `orParse` (return And)
        '|' -> do { parseThis '|'; return LogicalOr;  } `orParse` (return Or)
        ':' -> do { parseThis ':'; return Cons; } `orParse` do { parseThis '='; return RefAssign; } `orParse` (return Colon)
        '!' -> do { parseThis '='; return NotEquals; } `orParse` (return LogicalNegate)
        '+' -> return Add
        '-' -> return Sub
        '*' -> return Mul
        '%' -> return Mod
        '/' -> return Div
        '^' -> return Concat
        '@' -> return Append
        '?' -> return Hook
        ';' -> return Semi
        ',' -> return Comma
        '{' -> return LCurly
        '}' -> return RCurly
        '(' -> return LParen 
        ')' -> return RParen
        '[' -> return Lb
        ']' -> return Rb
        '~' -> return BinaryNegate
        _ -> parseFail $ (show c) ++ " cannot start an expression"

lexToken = foldr1 orParse [lexFloatValue,lexHexValue,lexDecValue,lexKeywordOrIdentifier,lexStringLiteral,lexSymbol]
lexJunk = parse0Plus $ do { lexComment; return (); } `orParse` do { parseItem isSpace; return (); }

startExpr minPrec = do
    tok <- parseAny
    let
        startUnaryOp tok = do { e <- startExpr (prec tok); return $ UnaryExpr tok e; }
        startExprModifier f = do { e <-startExpr 0; return $ f e }
    e <- case tok of
        Num n -> do return $ Constant (IntValue n)
        FNum n -> do return $ Constant (FloatValue n)
        StringLiteral s -> do return $ Constant (StringValue s)
        TrueT -> do return $ Constant (BoolValue True)
        FalseT -> do return $ Constant (BoolValue False)
        Null -> do return $ Constant NullValue
        Nil -> do return $ Constant (ListValue [])
        Identifier s -> return $ Variable s
        Sub -> startUnaryOp NumericNegate
        Mul -> startUnaryOp Deref
        BinaryNegate -> startUnaryOp tok
        LogicalNegate -> startUnaryOp tok
        Hd -> startUnaryOp tok
        Tl -> startUnaryOp tok
        Throw -> startExprModifier ThrowExpr
        Future -> startExprModifier FutureExpr
        Lazy ->startExprModifier LazyExpr
        Ref -> startExprModifier RefExpr
        If -> do 
            cond <- startExpr 0
            parseThis Then
            e1 <- startExpr 0
            do { parseThis Else; e2 <- startExpr 0; return $ IfExpr cond e1 e2 }  `orParse` do { return $ IfExpr cond e1 (Constant NullValue); }
        LCurly -> do
            s <- parseSequence
            parseThis RCurly
            return s;
        LParen -> do
            e <- startExpr 0
            parseThis RParen
            return e
        Lb -> do
            es <- parse0Sep (startExpr 0) (parseThis Comma)
            parseThis Rb
            return $ ListExpr es
        Switch -> do 
            e <- startExpr 0
            arms <- parse0Plus(do { parseThis Case; e1 <- startExpr 0; parseThis Colon; e2 <- startExpr 0; return (e1,e2); })
            do { parseThis Default; parseThis Colon; e2 <- startExpr 0; return $ CaseExpr e arms e2; } `orParse` do { return $ CaseExpr e arms  (Constant NullValue); }
        Fn -> do
            parseThis LParen
            args <- parse0Sep (do { Identifier i <- parseAny; return i; }) (parseThis Comma)
            parseThis RParen
            e <- startExpr 0
            return $ LambdaExpr args e
        _ -> parseFail $ (show tok) ++ " cannot start an expression"
    continueExpr minPrec e

continueExpr minPrec e = continueExpr' minPrec e `orParse` return e
continueExpr' minPrec e = do
    tok <- parseAny
    let 
        binaryOp = 
            if prec tok < minPrec || (prec tok == minPrec && (not $ rightAssoc tok)) then noParse
            else do 
                e2 <- startExpr $ prec tok
                continueExpr minPrec $ BinaryExpr e tok e2
    case tok of
        Add -> binaryOp
        Sub -> binaryOp
        Mul -> binaryOp
        Div -> binaryOp
        Mod -> binaryOp
        Lt -> binaryOp
        Gt -> binaryOp
        Le -> binaryOp
        Ge -> binaryOp
        Equals -> binaryOp
        NotEquals -> binaryOp
        And -> binaryOp
        Or -> binaryOp
        LogicalAnd -> binaryOp
        LogicalOr -> binaryOp
        Cons -> binaryOp
        Append -> binaryOp
        Concat -> binaryOp
        RefAssign -> binaryOp
        Hook -> do
            if (prec tok) <= minPrec then noParse else do
                e2 <- startExpr (prec tok)
                parseThis Colon
                e3 <- startExpr (prec tok)
                continueExpr minPrec $ IfExpr e e2 e3
        LParen -> do
            args <- parse0Sep (startExpr 0) (parseThis Comma)
            parseThis RParen
            continueExpr minPrec $ CallExpr e args
        Catch -> do
            Identifier v <- parseAny
            eh <- startExpr 0
            return $ ExceptionHandlerExpr e v eh
        _ -> noParse

parseStmnt = do
    let 
        parseDefine = do
            Identifier v <- parseAny
            parseThis Define
            e <- startExpr 0
            parseThis Semi
            return $ DefineStmnt v e
        parseWhile = do
            parseThis While
            cond <- startExpr 0
            parseThis Do
            body <- startExpr 0
            parseThis Semi
            return $ LoopStmnt cond body
        parseSemi = do
            parseThis Semi -- null statement is valid
            return $ ExprStmnt (Constant NullValue)
        parseExprStmnt = do
            e <- startExpr 0
            parseThis Semi
            return $ ExprStmnt e
    foldr1 orParse [parseDefine,parseWhile,parseSemi,parseExprStmnt]

parseSequence = do
    s <- parse0Plus parseStmnt
    return $ case s of
        [] -> Constant NullValue
        [ExprStmnt e] -> e
        _ -> SequenceExpr s


lexScript = do
    lexJunk
    eof <- parseIsEof
    if eof
        then return []
        else do
            i <- parseLocation
            t <- lexToken
            rest <- lexScript
            return ((t,i):rest)

parseScript = 
    do 
        list <- parseScript'
        return $ SequenceExpr list
    where 
        parseScript' = do 
            eof <- parseIsEof
            if eof
                then return []
                else do
                    s <- parseStmnt
                    rest <- parseScript'
                    return (s:rest)


data ExnResult a = ExnSuccess a | ExnThrow Value
newtype EvalFunc a = EvalFunc(Scope -> IO(ExnResult a))

instance Monad EvalFunc where
    return x = EvalFunc $ \s -> return $ ExnSuccess x
    EvalFunc af >>= f = EvalFunc $ \s -> do
        r <- af s
        case r of
            ExnSuccess r ->  bf s where EvalFunc bf = f r
            ExnThrow v -> return $ ExnThrow v

throw e = EvalFunc $ \s -> return $ ExnThrow e
throwS s = throw $ StringValue s
getScope = EvalFunc $  \s -> return $ ExnSuccess s

valToString v = do
    case v of
        IntValue i -> return $ show i
        FloatValue f -> return $ show f
        NullValue -> return "null"
        StringValue s -> return s
        BoolValue b -> return $ if b then "true" else "false"
        LambdaValue _ -> return "*Lambda*"
        ListValue l -> do
            ss <- mapM valToString l
            return $ "[" ++ (concat $ intersperse "," ss) ++ "]"
        _ -> throwS "Can't coerce to a string"

valToInt v = do
    case v of
        IntValue i -> return i
        StringValue s -> return $ read s -- FIXME: This'll error if it fails
        BoolValue b -> return $ if b then 1 else 0
        NullValue -> return 0
        _ -> throwS "Can't coerce to an int"

valToFloat v = do
    case v of
        FloatValue f ->  return f
        StringValue s -> return $ read s -- FIXME: This'll error if it fails
        _ -> do
            i <- valToInt v
            return $ fromIntegral i

valToBool v = return $
    case v of 
        IntValue i -> i /= 0
        StringValue s -> s /= ""
        BoolValue b -> b 
        NullValue -> False
        _ -> True

valToList v = return $
    case v of
        ListValue(l) -> l
        e -> [e]
        
valToRef (RefValue v) = return v
valToRef _ = throwS "Can't coerce to a ref"

valCmp (StringValue x) (StringValue y) = return $ if x == y then 0 else if x < y then -1 else 1
valCmp v1 v2 = do { a <- valToInt v1; b <- valToInt v2; return $ a - b }
valCmpToBool v1 v2 f = do { r <- valCmp v1 v2; return $ BoolValue $ f r }
boolToVal x = return $ BoolValue x

evalWithScope e s = EvalFunc $  \_ -> f s where EvalFunc f = eval e

floatOp r1 r2 f = do
    f1 <- valToFloat r1
    f2 <- valToFloat r2
    let f3 = f f1 f2
    return $ FloatValue f3

intOp r1 r2 f = do
    i1 <- valToInt r1
    i2 <- valToInt r2
    return $ IntValue $ f i1 i2

numOp (IntValue i1) (IntValue i2) _ f = return $ IntValue $ f i1 i2
numOp r1 r2 f _ = floatOp r1 r2 f

eval :: Expr -> EvalFunc Value

eval (Variable n) = do
    getScope >>= scopeGet n where
        scopeGet n ScopeTop = throwS $ "Can't find " ++ (show n) ++ " in scope"
        scopeGet n (ScopeVal k v next) | k == n = return v
                                       | otherwise = scopeGet n next

eval (ExceptionHandlerExpr body name handler) =  error "FIXME: ehexpr" {- EvalFunc $ \s ->
    let EvalFunc bf = eval body 
    in 
        case bf s of
            ExnSuccess r -> ExnSuccess r
            ExnThrow e -> eval handler ScopeVal(name,e,s) -}

eval (Constant n) = return n
eval (ThrowExpr e) = eval e >>= throw
eval (IfExpr cond t f) = do { r <- eval cond >>= valToBool; eval $ if r then t else f; }
eval (BinaryExpr e1 LogicalOr e2) = do
    r <- eval e1 >>= valToBool
    do { if r then return $ BoolValue True else eval e2 >>= valToBool >>= boolToVal }
    
eval (BinaryExpr e1 LogicalAnd e2) = do
    r <- eval e1 >>= valToBool
    do { if r then eval e2 >>= valToBool >>= boolToVal else return $ BoolValue False }

eval (BinaryExpr e1 opr e2) = do
    r1 <- eval e1
    r2 <- eval e2
    case opr of
        Equals -> valCmpToBool r1 r2 (==0)
        NotEquals -> valCmpToBool r1 r2 (/=0)
        Lt -> valCmpToBool r1 r2 (<0)
        Gt -> valCmpToBool r1 r2 (>0)
        Le -> valCmpToBool r1 r2 (<=0)
        Ge -> valCmpToBool r1 r2 (>=0)
        And -> intOp r1 r2 (.&.)
        Or -> intOp r1 r2 (.|.)
        Add -> numOp r1 r2 (+) (+)
        Sub -> numOp r1 r2 (-) (-)
        Mul -> numOp r1 r2 (*) (*)
        Div -> floatOp r1 r2 (/)
        Mod -> intOp r1 r2 mod
        Concat -> do { s1 <- valToString r1; s2 <- valToString r2; return $ StringValue (s1++s2) }
        Cons -> do { l <- valToList r1; return $ ListValue (r2:l) }
        Append -> do { l <- valToList r1; return $ ListValue (l++[r2]) }
        RefAssign -> error "FIXME: refassign" -- do { l <- valToRef; }
        _ -> error "Should never happen"

eval (UnaryExpr opr e) = do
    r <- eval e
    case opr of
        BinaryNegate -> do { i <- valToInt r; error "FIXME: binary negate"; }
        NumericNegate -> do { f <- valToFloat r; return $ FloatValue $ negate f }
        LogicalNegate -> do { b <- valToBool r; return $ BoolValue $ not b }
        Hd -> do
            l <- valToList r
            case l of 
                (h:_) -> return h
                _ -> throwS "Empty list"
        Tl -> do
            l <- valToList r
            case l of
                (_:t) -> return $ ListValue t
                _ -> throwS "Empty list"
        Deref -> error "FIXME: Deref"

eval (CaseExpr e arms def) = do
    r <- eval e
    let
        helper [] = eval def
        helper ((ke,re):arms) =
            do 
                r <- eval ke >>= valCmp r
                if r == 0 then eval re else helper arms
    helper arms

eval (ListExpr es) = do
    l <- mapM eval es
    return $ ListValue l

eval (LambdaExpr args expr) = do
    s <- getScope
    return $ LambdaValue $ ExprLambda args expr s

eval (CallExpr fe args) = do
    vs <- mapM eval args
    f <- eval fe
    -- FIXME: Resolve
    case f of
        LambdaValue(ExprLambda ns expr scope) -> do
            let
                putArgs [] _ s = s
                putArgs (n:ns) [] s = putArgs ns [] $ ScopeVal n NullValue s
                putArgs (n:ns) (v:vs) s = putArgs ns vs $ ScopeVal n v s
                newScope = putArgs ns vs (ScopeVal "callee" f (ScopeVal "args" (ListValue vs) scope))
            evalWithScope expr newScope
        LambdaValue(NativeLambda f) -> f vs
        _ -> throwS "not callable"

eval (SequenceExpr stmnts) =  do
    s <- getScope
    helper stmnts s NullValue where
        helper [] _ r = return r
        helper (s:ss) scope ret = case s of
            DefineStmnt name e ->  do
                r <- evalWithScope e scope
                helper ss (ScopeVal name r scope) r
            LoopStmnt cond body -> do
                let while' = do
                    r <- evalWithScope cond scope >>= valToBool
                    if r then do { eval body; while' } else return ()
                while'
                helper ss scope ret
            ExprStmnt e -> do
                r <- evalWithScope e scope
                helper ss scope r


lexString s = 
    case p (markRowsCols s 1 1) of
        Success(_,list) -> Success list
        Fail s l -> Fail s l
    where
        Parser p = lexScript
        markRowsCols s row col = 
            case s of 
                ('\n':cs) -> ('\n',m):markRowsCols cs (row+1) 1
                (c:cs) -> (c,m):markRowsCols cs row (col+1)
                [] -> []        
            where m = RowCol row col

-- FIXME: Make result a monad
parseString s = 
    case lexString s of
        Success toks -> case p toks of
            Success([],list) -> Success list
            Success(_,_) -> error "should never happen"
            Fail s l -> Fail s l
        Fail s l -> Fail s l
    where Parser p = parseScript

doIO io = EvalFunc $ \_ -> do
    r <- io
    return $ ExnSuccess r

natPrintln vs = do
    r <- natPrint vs
    doIO $ putChar '\n'
    return r

natPrint [] = return NullValue
natPrint (v:vs) = do
    s <- valToString v
    doIO $ putStr s
    natPrint vs

l = NativeLambda natPrintln
fv = LambdaValue l

defaultScope = ScopeVal "println" fv ScopeTop

run e = f defaultScope where EvalFunc f = eval e

runString s = do
    case parseString s of
        Success e -> do
            r <- run e
            case r of
                ExnSuccess v -> return $ "Return: " ++ (show v)
                ExnThrow v -> return $ "Uncaught Exception " ++ (show v) -- FIXME: Ugly
        Fail s l -> return $ "Parse fail: " ++ s ++ " at " ++ (show l) -- FIXME: Ugly

runFile fn = readFile fn >>= runString

main = do
    argv <- getArgs
    case argv of
        (f:_) -> runFile f >>= putStr
        _ -> putStr "Usage: brilang script\n"