module Main

import Data.List
import Data.List1
import Data.String
import Data.Vect
import Data.IORef
import Lib.Common
import Lib.Compile
import Lib.Parser
import Lib.Elab
import Lib.Parser.Impl
import Lib.Prettier
import Lib.ProcessDecl
import Lib.Token
import Lib.Tokenizer
import Lib.TopContext
import Lib.Types
import Lib.Syntax
import Lib.Syntax
import Node
-- import System
-- import System.Directory
-- import System.File
-- import System.Path
-- import Data.Buffer

jsonTopContext : M Json
jsonTopContext = do
  top <- get
  pure $ JsonObj (("context", JsonArray (map jsonDef $ listValues top.defs)) :: Nil)
  where
    jsonDef : TopEntry -> Json
    -- There is no FC here...
    jsonDef (MkEntry fc (QN ns name) type def) = JsonObj
      (  ("fc", toJson fc)
      :: ("name", toJson name)
      :: ("type", toJson (render 80 $ pprint Nil type) )
      :: Nil)

dumpContext : TopContext -> M Unit
dumpContext top = do
    putStrLn "Context:"
    go $ listValues top.defs
    putStrLn "---"
  where
    go : List TopEntry -> M Unit
    go Nil = pure MkUnit
    go (x :: xs) = putStrLn "    \{show x}" >> go xs

writeSource : String -> M Unit
writeSource fn = do
  docs <- compile
  let src = unlines $
        ( "\"use strict\";"
        ::  "const PiType = (h0, h1) => ({ tag: \"PiType\", h0, h1 })"
        :: Nil)
        ++ map (render 90 ∘ noAlt) docs
  (Right _) <- liftIO {M} $ writeFile fn src
    | Left err => exitFailure (show err)
  -- (Right _) <- chmodRaw fn 493 | Left err => exitFailure (show err)
  pure MkUnit


parseDecls : String -> Operators -> TokenList -> SnocList Decl -> M (List Decl × Operators)
parseDecls fn ops Nil acc = pure (acc <>> Nil, ops)
parseDecls fn ops toks@(first :: _) acc =
  case partialParse fn (sameLevel parseDecl) ops toks of
    Left (err, toks) => do
      putStrLn $ showError "" err
      addError err
      parseDecls fn ops (recover toks) acc
    Right (decl,ops,toks) => parseDecls fn ops toks (acc :< decl)
  where
    recover : TokenList -> TokenList
    recover Nil = Nil
    -- skip to top token, but make sure there is progress
    recover (tok :: toks) = if tok.bounds.startCol == 0 && tok.bounds /= first.bounds
      then (tok :: toks)
      else recover toks

-- New style loader, one def at a time
processModule : FC -> String -> List String -> QName -> M String
processModule importFC base stk qn@(QN ns nm) = do
  top <- get
  -- TODO make top.loaded a List QName
  let name = joinBy "." (snoc ns nm)
  let (False) = elem name top.loaded | _ => pure ""
  modify (\ top => MkTop top.defs top.metaCtx top.verbose top.errors (name :: top.loaded)top.ops)
  let fn = (joinBy "/" (base :: ns)) ++ "/" ++ nm ++ ".newt"
  (Right src) <- liftIO {M} $ readFile fn
    | Left err => exitFailure "ERROR at \{show importFC}: error reading \{fn}: \{show err}"
  let (Right toks) = tokenise fn src
    | Left err => exitFailure (showError src err)

  let (Right ((nameFC, modName), ops, toks)) = partialParse fn parseModHeader top.ops toks
    | Left (err, toks) => exitFailure (showError src err)

  putStrLn "module \{modName}"
  let ns = split modName "."
  let (path, modName') = unsnoc $ split1 modName "."
  -- let bparts = split base "/"
  let (True) = qn == QN path modName'
    | _ => exitFailure "ERROR at \{show nameFC}: module name \{show modName} doesn't match file name \{show fn}"

  let (Right (imports, ops, toks)) = partialParse fn parseImports ops toks
    | Left (err, toks) => exitFailure (showError src err)

  for imports $ \case
    MkImport fc name' => do
      let (a,b) = unsnoc $ split1 name' "."
      let qname = QN a b
      -- we could use `fc` if it had a filename in it
      when (elem name' stk) $ \ _ => error emptyFC "import loop \{show name} -> \{show name'}"

      processModule fc base (name :: stk) qname

  top <- get
  mc <- readIORef top.metaCtx
  -- REVIEW suppressing unsolved and solved metas from previous files
  -- I may want to know about (or exitFailure early on) unsolved
  let mstart = length mc.metas
  -- let Right (decls, ops, toks) = partialParse fn (manySame parseDecl) top.ops toks
  --   | Left (err, toks) => exitFailure (showError src err)
  (decls, ops) <- parseDecls fn top.ops toks Lin
  modify (\ top => MkTop top.defs top.metaCtx top.verbose top.errors top.loaded ops)
  putStrLn "process Decls"

  traverse (tryProcessDecl ns) (collectDecl decls)

  -- we don't want implict errors from half-processed functions
  -- but suppress them all on error for simplicity.
  errors <- readIORef top.errors
  if stk == Nil then logMetas (cast mstart) else pure MkUnit
  pure src
  where

    -- parseDecls :
    -- tryParseDecl :
    tryProcessDecl : List String -> Decl -> M Unit
    tryProcessDecl ns decl = do
      Left err <- tryError $ processDecl ns decl | _ => pure MkUnit
      addError err


baseDir : SnocList String -> SnocList String -> Either String String
baseDir dirs Lin = Right $ joinBy "/" (dirs <>> Nil)
baseDir (dirs :< d) (ns :< n) = if d == n
  then baseDir dirs ns
  else Left "module path doesn't match directory"
baseDir Lin _ = Left "module path doesn't match directory"

showErrors : String -> String -> M Unit
showErrors fn src = do
  top <- get
  (Nil) <- liftIO {M} $ readIORef top.errors
    | errors => do
        ignore $ for errors $ \err =>
          putStrLn (showError src err)
        -- if err.file == fn
        -- then putStrLn (showError src err)
        -- else putStrLn (showError "" err)
        exitFailure "Compile failed"
  pure MkUnit


processFile : String -> M Unit
processFile fn = do
  putStrLn "*** Process \{fn}"
  let parts = split1 fn "/"
  let (dirs,file) = unsnoc parts
  let dir = if dirs == Nil then "." else joinBy "/" dirs
  let (name, ext) = splitFileName file
  putStrLn "\{show dir} \{show name} \{show ext}"
  (Right src) <- liftIO {M} $ readFile fn
    | Left err => error (MkFC fn (0,0)) "error reading \{fn}: \{show err}"
  let (Right toks) = tokenise fn src
    | Left err => throwError err
  let (Right ((nameFC, modName), _, _)) = partialParse fn parseModHeader EmptyMap toks
    | Left (err,toks) => throwError err
  let ns = split modName "."
  let (path, modName') = unsnoc $ split1 modName "."

  -- Any case splits after this point causes it to loop, no idea why

  -- let (True) = modName' == name
  --   | False => throwError $ E (MkFC fn (0,0)) "module name \{modName'} doesn't match \{name}"
  -- let (Right base) = baseDir (Lin <>< dirs) (Lin <>< path)
  --   | Left err => pure MkUnit -- exitFailure "ERROR at \{show nameFC}: \{err}"
  -- let base = if base == "" then "." else base

  -- declare internal primitives
  processDecl ("Prim" :: Nil) (PType emptyFC "Int" Nothing)
  processDecl ("Prim" :: Nil) (PType emptyFC "String" Nothing)
  processDecl ("Prim" :: Nil) (PType emptyFC "Char" Nothing)
  let base = "aoc2024" -- FIXME
  src <- processModule emptyFC base Nil (QN path modName')
  top <- get
  -- -- dumpContext top

  -- (Nil) <- liftIO {M} $ readIORef top.errors
  --   | errors => do
  --     for_ errors $ \err =>
  --       putStrLn (showError src err)
  --     exitFailure "Compile failed"
  showErrors fn src
  pure MkUnit


cmdLine : List String -> M (Maybe String × List String)
cmdLine Nil = pure (Nothing, Nil)
cmdLine ("--top" :: args) = cmdLine args -- handled later
cmdLine ("-v" :: args) = do
  modify (\ top => MkTop top.defs top.metaCtx True top.errors top.loaded top.ops)
  cmdLine args
cmdLine ("-o" :: fn :: args) = do
  (out, files) <- cmdLine args
  pure ((out <|> Just fn), files)

cmdLine (fn :: args) = do
  let (True) = isSuffixOf ".newt" fn
    | _ => error emptyFC "Bad argument \{show fn}"
  (out, files) <- cmdLine args
  pure $ (out, fn :: files)

main' : M Unit
main' = do
  let (arg0 :: args) = getArgs
    | _ => error emptyFC "error reading args"
  (out, files) <- cmdLine args
  traverse processFile files

  when (elem "--top" args) $ \ _ => do
    json <- jsonTopContext
    putStrLn "TOP:\{renderJson json}"

  case out of
    Nothing => pure MkUnit
    Just name => writeSource name


main : IO Unit
main = do
  -- we'll need to reset for each file, etc.
  ctx <- emptyTop
  (Right _)  <- .runM main' ctx
    | Left err => exitFailure "ERROR at \{show $ getFC err}: \{errorMsg err}"
  putStrLn "done"