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 System
import System.Directory
import System.File
import System.Path
import Data.Buffer

fail : String -> M a
fail msg = putStrLn msg >> exitFailure

jsonTopContext : M Json
jsonTopContext = do
  top <- get
  pure $ JsonObj [("context", JsonArray (map jsonDef $ toList top.defs))]
  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 [] type) )
      ]

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

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


parseDecls : String -> Operators -> TokenList -> SnocList Decl -> M (List Decl, Operators)
parseDecls fn ops [] acc = pure (acc <>> [], 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 [] = []
    -- 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

fastReadFile : HasIO io => String -> io (Either FileError String)
fastReadFile fn = do
  Right buf <- createBufferFromFile fn | Left err => pure $ Left err
  len <- rawSize buf
  Right <$> getString buf 0 len


||| 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 { loaded $= (name::) }
  let fn = (String.joinBy "/" (base :: ns)) ++ "/" ++ nm ++ ".newt"
  Right src <- fastReadFile $ fn
    | Left err => fail "ERROR at \{show importFC}: error reading \{fn}: \{show err}"
  let Right toks = tokenise fn src
    | Left err => fail (showError src err)

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

  putStrLn "module \{modName}"
  let ns = forget $ split (== '.') modName
  let (path, modName') = unsnoc $ split (== '.') modName
  let bparts = split (== '/') base
  let True = qn == QN path modName'
    | _ => fail "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) => fail (showError src err)

  for_ imports $ \ (MkImport fc name') => do
    let (a,b) = unsnoc $ split (== '.') name'
    let qname = QN a b
    -- we could use `fc` if it had a filename in it
    when (name' `elem` 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 fail early on) unsolved
  let mstart = length mc.metas
  -- let Right (decls, ops, toks) := partialParse fn (manySame parseDecl) top.ops toks
  --   | Left (err, toks) => fail (showError src err)
  (decls, ops) <- parseDecls fn top.ops toks [<]
  modify { ops := 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.
  [] <- readIORef top.errors
    | errors => do
      for_ errors $ \err =>
        putStrLn (showError src err)
      exitFailure

  if stk == [] then logMetas mstart else pure ()
  pure src
  where

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

processFile : String -> M ()
processFile fn = do
  putStrLn "*** Process \{fn}"
  let parts = split (== '/') 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}"

  top <- get
  Right src <- fastReadFile $ fn
    | Left err => fail "ERROR at \{fn}:(0, 0): error reading \{fn}: \{show err}"
  let Right toks = tokenise fn src
    | Left err => fail (showError src err)
  let Right ((nameFC, modName), ops, toks) := partialParse fn parseModHeader top.ops toks
    | Left (err, toks) => fail (showError src err)
  let ns = forget $ split (== '.') modName
  let (path, modName') = unsnoc $ split (== '.') modName
  let True = modName' == name
    | False => fail "ERROR at \{fn}:(0, 0): module name \{modName'} doesn't match \{name}"
  let Right base = baseDir (Lin <>< dirs) (Lin <>< path)
    | Left err => fail "ERROR at \{show nameFC}: \{err}"
  let base = if base == "" then "." else base
  -- declare internal primitives
  processDecl ["Prim"] (PType emptyFC "Int" Nothing)
  processDecl ["Prim"] (PType emptyFC "String" Nothing)
  processDecl ["Prim"] (PType emptyFC "Char" Nothing)

  src <- processModule emptyFC base [] (QN path modName')
  top <- get
  -- dumpContext top

  [] <- readIORef top.errors
    | errors => do
      for_ errors $ \err =>
        putStrLn (showError src err)
      exitFailure
  pure ()

  where
    baseDir : SnocList String -> SnocList String -> Either String String
    baseDir dirs Lin = Right $ joinBy "/" (dirs <>> [])
    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"

cmdLine : List String -> M (Maybe String, List String)
cmdLine [] = pure (Nothing, [])
cmdLine ("--top" :: args) = cmdLine args -- handled later
cmdLine ("-v" :: args) = do
  modify { verbose := True }
  cmdLine args
cmdLine ("-o" :: fn :: args) = do
  (out, files) <- cmdLine args
  pure (out <|> Just fn, files)

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

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

  when (elem "--top" args) $ putStrLn "TOP:\{renderJson !jsonTopContext}"

  case out of
    Nothing => pure ()
    Just name => writeSource name

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