138 lines
3.6 KiB
Idris
138 lines
3.6 KiB
Idris
module Main
|
|
|
|
-- import Control.App
|
|
import Control.Monad.Error.Either
|
|
import Control.Monad.Error.Interface
|
|
import Control.Monad.State
|
|
import Data.List
|
|
import Data.String
|
|
import Data.Vect
|
|
import Lib.Check
|
|
import Lib.Parser
|
|
import Lib.Parser.Impl
|
|
import Lib.Prettier
|
|
import Lib.Token
|
|
import Lib.Tokenizer
|
|
import Lib.TopContext
|
|
import Lib.TT
|
|
import Syntax
|
|
import Syntax
|
|
import System
|
|
import System.Directory
|
|
import System.File
|
|
|
|
{-
|
|
|
|
Main2.idr has an older App attempt without the code below.
|
|
|
|
It has a repl, so we might want to re-integrate that code. And it uses
|
|
App, but we have a way to make that work on javascript.
|
|
|
|
I still want to stay in MonadError outside this file though.
|
|
|
|
|
|
-}
|
|
|
|
M : Type -> Type
|
|
M = (StateT TopContext (EitherT Impl.Error IO))
|
|
|
|
|
|
dumpContext : TopContext -> M ()
|
|
dumpContext top = do
|
|
putStrLn "Context:"
|
|
go top.defs
|
|
putStrLn "---"
|
|
where
|
|
go : List TopEntry -> M ()
|
|
go [] = pure ()
|
|
go (x :: xs) = go xs >> putStrLn " \{show x}"
|
|
|
|
processDecl : Decl -> M ()
|
|
processDecl (TypeSig nm tm) = do
|
|
top <- get
|
|
putStrLn "TypeSig \{nm} \{show tm}"
|
|
ty <- check top (mkCtx top.metas) tm VU
|
|
putStrLn "got \{show ty}"
|
|
modify $ claim nm ty
|
|
|
|
-- FIXME - this should be in another file
|
|
processDecl (Def nm raw) = do
|
|
let m : MonadError Error M := %search
|
|
putStrLn "def \{show nm}"
|
|
ctx <- get
|
|
let pos = case raw of
|
|
RSrcPos pos _ => pos
|
|
_ => (0,0)
|
|
|
|
let Just entry = lookup nm ctx
|
|
| Nothing => throwError $ E pos "skip def \{nm} without Decl"
|
|
let (MkEntry name ty Axiom) := entry
|
|
| _ => throwError $ E pos "\{nm} already defined"
|
|
putStrLn "check \{nm} = \{show raw} at \{show $ ty}"
|
|
let vty = eval empty CBN ty
|
|
tm <- check ctx (mkCtx ctx.metas) raw vty
|
|
putStrLn "Ok \{show tm}"
|
|
put (addDef ctx nm tm ty)
|
|
|
|
processDecl (DImport str) = throwError $ E (0,0) "import not implemented"
|
|
|
|
processDecl (Data nm ty cons) = do
|
|
-- It seems like the FC for the errors are not here?
|
|
ctx <- get
|
|
tyty <- check ctx (mkCtx ctx.metas) ty VU
|
|
-- TODO check tm is VU or Pi ending in VU
|
|
-- Maybe a pi -> binders function
|
|
-- TODO we're putting in axioms, we need constructors
|
|
-- for each constructor, check and add
|
|
modify $ claim nm tyty
|
|
ctx <- get
|
|
for_ cons $ \x => case x of
|
|
-- expecting tm to be a Pi type
|
|
(TypeSig nm' tm) => do
|
|
ctx <- get
|
|
-- TODO check pi type ending in full tyty application
|
|
dty <- check ctx (mkCtx ctx.metas) tm VU
|
|
modify $ claim nm' dty
|
|
_ => throwError $ E (0,0) "expected TypeSig"
|
|
|
|
pure ()
|
|
where
|
|
checkDeclType : Tm -> M ()
|
|
checkDeclType U = pure ()
|
|
checkDeclType (Pi str icit t u) = checkDeclType u
|
|
checkDeclType _ = throwError $ E (0,0) "data type doesn't return U"
|
|
|
|
processFile : String -> M ()
|
|
processFile fn = do
|
|
putStrLn "*** Process \{fn}"
|
|
Right src <- readFile $ fn
|
|
| Left err => printLn err
|
|
let toks = tokenise src
|
|
let Right res = parse parseMod toks
|
|
| Left y => putStrLn (showError src y)
|
|
putStrLn $ render 80 $ pretty res
|
|
printLn "process Decls"
|
|
Right _ <- tryError $ traverse_ processDecl res.decls
|
|
| Left y => putStrLn (showError src y)
|
|
|
|
dumpContext !get
|
|
|
|
main' : M ()
|
|
main' = do
|
|
args <- getArgs
|
|
putStrLn "Args: \{show args}"
|
|
let (_ :: files) = args
|
|
| _ => putStrLn "Usage: newt foo.newt"
|
|
-- Right files <- listDir "eg"
|
|
-- | Left err => printLn err
|
|
|
|
traverse_ processFile (filter (".newt" `isSuffixOf`) files)
|
|
|
|
main : IO ()
|
|
main = do
|
|
-- we'll need to reset for each file, etc.
|
|
ctx <- empty
|
|
Right _ <- runEitherT $ runStateT ctx $ main'
|
|
| Left (E (c, r) str) => putStrLn "Error: \{show c} \{show r} \{show str}"
|
|
putStrLn "done"
|