content: module Expr where
  
  import Control.Applicative (Alternative (empty, many), optional, (<|>))
  import Data.Functor (($>))
  import Data.IORef
  import Data.Map qualified as M
  import Data.Maybe (fromMaybe)
  import Error
  import Parser
  import State (Context, Interpreter)
  import Token qualified as T
  
  data Object
    = StringObject String
    | BooleanObject Bool
    | NumberObject Double
    | FunctionObject Function
    | ClassObject Class
    | InstanceObject Instance
    | Nil
    deriving (Eq)
  
  data Function = Function
    { arity :: Int,
      closureRef :: IORef (Context Object),
      fun :: [Object] -> Interpreter Object Object
    }
  
  data Class = Class
    { name :: T.Ident,
      initialiser :: Maybe Function,
      methods :: M.Map T.Ident Function,
      superClass :: Maybe Class
    }
  
  instance Show Class where
    show (Class name _ _ _) = name
  
  instance Eq Class where
    (==) (Class a _ _ _) (Class b _ _ _) = a == b
  
  data Instance = Instance
    { cls :: Class,
      properties :: IORef (M.Map T.Ident Object)
    }
    deriving (Eq)
  
  instance Eq Function where
    (==) _ _ = False
  
  instance Show Object where
    show (StringObject s) = s
    show (BooleanObject True) = "true"
    show (BooleanObject False) = "false"
    show (NumberObject n) = show n
    show (FunctionObject _) = "<fn>"
    show (ClassObject (Class n _ _ _)) = n
    show (InstanceObject (Instance cls _)) = show cls ++ " instance"
    show Nil = "nil"
  
  truthy :: Object -> Bool
  truthy (BooleanObject b) = b
  truthy Nil = False
  truthy _ = True
  
  type BinaryOperator = Object -> Object -> Either RuntimeError Object
  
  data Binary = Binary
    { binLeft :: Expr,
      binOp :: BinaryOperator,
      binRight :: Expr
    }
  
  instance Show Binary where
    show (Binary {binLeft, binRight}) = "Binary {" ++ show binLeft ++ " on " ++ show binRight ++ "}"
  
  type UnaryOperator = Object -> Either RuntimeError Object
  
  data Unary = Unary
    { unOp :: UnaryOperator,
      expr :: Expr
    }
  
  instance Show Unary where
    show (Unary {expr}) = "Unary {" ++ show expr ++ "}"
  
  data Assign = Assign
    { ident :: T.Ident,
      value :: Expr
    }
    deriving (Show)
  
  data LogicalOperator = And | Or deriving (Show, Eq)
  
  data Logical = Logical
    { logleft :: Expr,
      logOp :: LogicalOperator,
      logRight :: Expr
    }
    deriving (Show)
  
  data Call = Call
    { callee :: Expr,
      args :: [Expr]
    }
    deriving (Show)
  
  data Get = Get
    { getObject :: Expr,
      getMember :: T.Ident
    }
    deriving (Show)
  
  data Set = Set
    { setObject :: Expr,
      setMember :: T.Ident,
      setValue :: Expr
    }
    deriving (Show)
  
  data Expr
    = LiteralExpr Object
    | BinaryExpr Binary
    | UnaryExpr Unary
    | GroupingExpr Expr
    | AssignExpr Assign
    | VarExpr T.Ident
    | LogicalExpr Logical
    | CallExpr Call
    | GetExpr Get
    | SetExpr Set
    deriving (Show)
  
  -- Operators!
  
  invalidBinary :: String -> Object -> Object -> RuntimeError
  invalidBinary op left right = InvalidOperationError $ "operation " ++ op ++ " between " ++ show left ++ " and " ++ show right ++ " is invalid"
  
  eq :: BinaryOperator
  eq left right = return $ BooleanObject $ left == right
  
  neq :: BinaryOperator
  neq left right = return $ BooleanObject $ left /= right
  
  gr :: BinaryOperator
  gr (NumberObject left) (NumberObject right) = return $ BooleanObject $ left > right
  gr left right = Left $ invalidBinary ">" left right
  
  greq :: BinaryOperator
  greq (NumberObject left) (NumberObject right) = return $ BooleanObject $ left >= right
  greq left right = Left $ invalidBinary ">=" left right
  
  le :: BinaryOperator
  le (NumberObject left) (NumberObject right) = return $ BooleanObject $ left < right
  le left right = Left $ invalidBinary "<" left right
  
  leeq :: BinaryOperator
  leeq (NumberObject left) (NumberObject right) = return $ BooleanObject $ left <= right
  leeq left right = Left $ invalidBinary "<=" left right
  
  add :: BinaryOperator
  add (NumberObject left) (NumberObject right) = return $ NumberObject $ left + right
  add (StringObject left) (StringObject right) = return $ StringObject $ left ++ right
  add left right = Left $ invalidBinary "+" left right
  
  subtract' :: BinaryOperator
  subtract' (NumberObject left) (NumberObject right) = return $ NumberObject $ left - right
  subtract' left right = Left $ invalidBinary "-" left right
  
  multiply :: BinaryOperator
  multiply (NumberObject left) (NumberObject right) = return $ NumberObject $ left * right
  multiply left right = Left $ invalidBinary "*" left right
  
  divide :: BinaryOperator
  divide (NumberObject _) (NumberObject 0) = Left $ InvalidOperationError "cannot divide by zero!"
  divide (NumberObject left) (NumberObject right) = return $ NumberObject $ left / right
  divide left right = Left $ invalidBinary "/" left right
  
  invalidUnary :: String -> Object -> RuntimeError
  invalidUnary op object = InvalidOperationError $ "operation " ++ op ++ " on " ++ show object ++ " is invalid"
  
  not' :: UnaryOperator
  not' object = return $ BooleanObject $ not $ truthy object
  
  neg :: UnaryOperator
  neg (NumberObject n) = return $ NumberObject $ -n
  neg object = Left $ invalidUnary "-" object
  
  -- Expression Parsing!
  
  matches :: T.TokenType -> Parser T.Tokens T.Token
  matches t = Parser $ \case
    (x : xs) | T.ty x == t -> Just (x, xs)
    _ -> Nothing
  
  literal' :: Parser T.Tokens Expr
  literal' = Parser $ \case
    (T.Token {T.ty = T.LiteralToken l} : xs) -> Just (LiteralExpr (toObject l), xs)
    _ -> Nothing
    where
      toObject = \case
        T.NumberLiteral (T.Number w f) -> NumberObject $ toDouble w f
        T.BooleanLiteral b -> BooleanObject b
        T.StringLiteral s -> StringObject s
        T.NilLiteral -> Nil
  
      toDouble w f =
        let divisor = 10 ^ length (show f) -- neither me or chatgpt could do better...
         in fromIntegral w + fromIntegral f / divisor
  
  grouping :: Parser T.Tokens Expr
  grouping = matches (T.SingleToken T.LeftParen) *> (GroupingExpr <$> expression) <* matches (T.SingleToken T.RightParen)
  
  primary :: Parser T.Tokens Expr
  primary = literal' <|> grouping <|> (VarExpr <$> identifier')
  
  arguments :: Parser T.Tokens [Expr]
  arguments = (:) <$> expression <*> many (matches (T.SingleToken T.Comma) *> expression)
  
  call :: Parser T.Tokens Expr
  call = do
    first <- primary
    rest first
    where
      rest first =
        ( do
            args <- matches (T.SingleToken T.LeftParen) *> (fromMaybe [] <$> optional arguments) <* matches (T.SingleToken T.RightParen)
            rest (CallExpr $ Call first args)
        )
          <|> ( do
                  member <- matches (T.SingleToken T.Dot) *> identifier'
                  rest (GetExpr $ Get first member)
              )
          <|> pure first
  
  unaryOperator :: Parser T.Tokens UnaryOperator
  unaryOperator =
    matches (T.MultiToken T.Bang) $> not'
      <|> matches (T.SingleToken T.Minus) $> neg
  
  unary :: Parser T.Tokens Expr
  unary = UnaryExpr <$> (Unary <$> unaryOperator <*> unary) <|> call
  
  binary :: Parser T.Tokens Expr -> Parser T.Tokens BinaryOperator -> Parser T.Tokens Expr
  binary e op = do
    left <- e
    rest left
    where
      rest left =
        ( do
            operator <- op
            right <- e
            rest (BinaryExpr $ Binary left operator right)
        )
          <|> pure left
  
  factor :: Parser T.Tokens Expr
  factor = binary unary $ matches (T.SingleToken T.Slash) $> divide <|> matches (T.SingleToken T.Star) $> multiply
  
  term :: Parser T.Tokens Expr
  term = binary factor $ matches (T.SingleToken T.Minus) $> subtract' <|> matches (T.SingleToken T.Plus) $> add
  
  comparison :: Parser T.Tokens Expr
  comparison =
    binary
      term
      $ matches (T.MultiToken T.Greater) $> gr
        <|> matches (T.MultiToken T.GreaterEqual) $> greq
        <|> matches (T.MultiToken T.Less) $> le
        <|> matches (T.MultiToken T.LessEqual) $> leeq
  
  equality :: Parser T.Tokens Expr
  equality =
    binary
      comparison
      $ matches (T.MultiToken T.BangEqual) $> neq
        <|> (matches (T.MultiToken T.EqualEqual) $> eq)
  
  identifier' :: Parser T.Tokens String
  identifier' = Parser $ \case
    (x : xs) -> case T.ty x of
      T.IdentifierToken i -> Just (i, xs)
      _ -> Nothing
    _ -> Nothing
  
  logical :: Parser T.Tokens Expr -> Parser T.Tokens LogicalOperator -> Parser T.Tokens Expr
  logical e op = do
    left <- e
    rest left
    where
      rest left =
        ( do
            operator <- op
            right <- e
            rest (LogicalExpr $ Logical left operator right)
        )
          <|> pure left
  
  logicalAnd :: Parser T.Tokens Expr
  logicalAnd = logical equality (matches (T.KeywordToken T.And) $> And)
  
  logicalOr :: Parser T.Tokens Expr
  logicalOr = logical logicalAnd (matches (T.KeywordToken T.Or) $> Or)
  
  assignment :: Parser T.Tokens Expr
  assignment =
    ( do
        assignee <- call <* matches (T.MultiToken T.Equal)
        case assignee of
          GetExpr (Get expr member) -> SetExpr . Set expr member <$> assignment
          VarExpr var -> AssignExpr . Assign var <$> assignment
          _ -> empty
    )
      <|> logicalOr
  
  expression :: Parser T.Tokens Expr
  expression = assignment
  