249 lines
8.1 KiB
Agda
249 lines
8.1 KiB
Agda
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"
|