module Compiler where

import qualified Ast as A
import Control.Monad.State
import Data.List (sort)
import qualified Data.Map as Map
import Data.Maybe (isJust)
import System.Environment (getEnv, getEnvironment)
import Text.Parsec (ParseError, SourcePos)
import Text.Read (Lexeme (String))

data Error = Error String SourcePos deriving (Eq)

instance Show Error where
  show (Error message pos) =
    "error: " ++ show pos ++ ":\n" ++ message

instance Ord Error where
  compare (Error _ pos1) (Error _ pos2) = compare pos1 pos2

showErrorList :: [Error] -> String
showErrorList errs = unlines $ map show (sort errs)

type Sym = (A.Ident, A.Type, SourcePos)

type SymMap = Map.Map A.Ident Sym

data Env = Env SymMap (Maybe Env) deriving (Show)

-- first parameter tells if we look on the local environment
-- or if we should check also in the parent(s)
getSymB :: Bool -> Env -> A.Ident -> Maybe Sym
getSymB local (Env m parent) id =
  case (local, Map.lookup id m) of
    (False, Nothing) -> do
      p <- parent
      getSym p id
    (_, s) -> s

-- get symbol
getSym :: Env -> A.Ident -> Maybe Sym
getSym = getSymB False

-- get symbol local
getSyml :: Env -> A.Ident -> Maybe Sym
getSyml = getSymB True

-- if a symbol exists
existsSym :: Env -> A.Ident -> Bool
existsSym env sym = isJust $ getSym env sym

-- if a local symbol exists
existsSyml :: Env -> A.Ident -> Bool
existsSyml env sym = isJust $ getSyml env sym

-- add symbol
addSym :: Env -> Sym -> Env
addSym (Env m parent) (id, typ, pos) = case getSym env id of
  Nothing -> Env (Map.insert id sym m) parent
  Just s -> Env (Map.singleton id sym) $ Just env
  where
    env = (Env m parent)
    sym = (id, typ, pos)

-- adds a new local environment
addEnv :: Env -> Env
addEnv env = Env Map.empty $ Just env

-- add a local symbol if it doesn't exist
addSymUniq :: Env -> Sym -> Either Error Env
addSymUniq ev (id, typ, pos) = case getSyml ev id of
  Nothing -> Right $ addSym ev sym
  Just (_, _, p) -> Left $ Error ("\"" ++ id ++ "\" already defined in " ++ show p) pos
  where
    sym = (id, typ, pos)

toFuncType :: [A.FuncParam] -> Maybe A.Type -> A.Type
toFuncType params rtyp =
  A.FuncType (map (\(_, t, _) -> t) params) rtyp

type CompState = (Env, [Error])

type CompResult = Either [Error] ()

startState :: CompState
startState = (Env Map.empty Nothing, [])

compile :: [A.Expr] -> State CompState CompResult
compile (x : xs) = do
  case x of
    (A.Module name pos) -> return $ Right ()
    (A.BinOp _ a b) -> compile [a, b]
    (A.Func ident params ret body priv pos) -> do
      -- current env
      (ev, errs) <- get
      -- with function and parameters
      (nev, nerrs) <-
        return $ case addSymUniq ev (ident, toFuncType params ret, pos) of
          Left e -> (ev, e : errs)
          Right fev ->
            foldl
              ( \(ev, errs) (id, typ, pos) -> case addSymUniq ev (id, typ, pos) of
                  Right ev -> (ev, errs)
                  Left nerr -> (ev, nerr : errs)
              )
              (addEnv fev, errs)
              params
      put (nev, nerrs)
      r <- compile body
      (_, errs) <- get
      put (ev, errs)
      return r
    (A.Call ident args pos) -> do
      id <- compile [ident]
      return $ Right ()
    (A.Return value pos) -> case value of
      Nothing -> return $ Right ()
      Just v -> compile [v]
    (A.Var ident pos) -> do
      (ev, errs) <- get
      if existsSym ev ident
        then return $ Right ()
        else do
          put (ev, Error ("undefined variable \"" ++ ident ++ "\"") pos : errs)
          return $ Right ()
    _ -> compile []
  compile xs
compile [] = do
  (_, errs) <- get
  case errs of
    [] -> return $ Right ()
    _ -> return $ Left errs