|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE BlockArguments #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE DeriveAnyClass #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
module Main where
|
|
|
|
import Control.Monad.IO.Class
|
|
import Control.Monad.Reader
|
|
import Control.Exception
|
|
|
|
import qualified Data.ByteString.Lazy as Bsl
|
|
import qualified Data.Text.Encoding as T
|
|
import qualified Data.Text.Lazy.IO as Lt
|
|
import qualified Data.Map.Strict as Map
|
|
import qualified Data.Text.Lazy as Lt
|
|
import qualified Data.Text.IO as T
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Text as T
|
|
import Data.Sequence (Seq)
|
|
import Data.Text ( Text )
|
|
import Data.Foldable
|
|
import Data.Maybe
|
|
import Data.IORef
|
|
|
|
import Debug (traceDocM)
|
|
|
|
import Elab.Monad hiding (switch)
|
|
import Elab.WiredIn
|
|
import Elab.Eval
|
|
import Elab
|
|
|
|
import Options.Applicative
|
|
|
|
import Presyntax.Presyntax (Posn(Posn))
|
|
import Presyntax.Parser
|
|
import Presyntax.Tokens
|
|
import Presyntax.Lexer
|
|
|
|
import Prettyprinter
|
|
|
|
import Syntax.Pretty
|
|
import Syntax
|
|
|
|
import System.Console.Haskeline
|
|
import System.Exit
|
|
|
|
main :: IO ()
|
|
main = do
|
|
opts <- execParser parser
|
|
case opts of
|
|
Load files exp -> do
|
|
env <- checkFiles files
|
|
case exp of
|
|
[] -> enterReplIn env
|
|
xs -> traverse_ (evalArgExpr env) xs
|
|
Check files verbose -> do
|
|
env <- checkFiles files
|
|
when verbose $ dumpEnv env
|
|
Repl -> enterReplIn =<< emptyEnv
|
|
|
|
evalArgExpr :: ElabEnv -> String -> IO ()
|
|
evalArgExpr env str =
|
|
case runAlex (Bsl.fromStrict (T.encodeUtf8 inp)) parseExp of
|
|
Right e ->
|
|
flip runElab env (do
|
|
(e, _) <- infer e
|
|
liftIO . Lt.putStrLn . render . prettyTm . quote . zonk =<< Elab.Eval.eval e)
|
|
`catch` \e -> do
|
|
displayExceptions' inp (e :: SomeException)
|
|
Left e -> liftIO $ print e
|
|
where
|
|
inp = T.pack str
|
|
|
|
enterReplIn :: ElabEnv -> IO ()
|
|
enterReplIn env =
|
|
do
|
|
let env' = mkrepl env
|
|
envref <- newIORef env'
|
|
runInputT (setComplete (complete envref) defaultSettings) (loop env' envref)
|
|
where
|
|
mkrepl env = env { commHook = Lt.putStrLn . render }
|
|
|
|
complete :: IORef ElabEnv -> (String, String) -> IO (String, [Completion])
|
|
complete c = completeWord Nothing " \n\t\r" go where
|
|
go w = do
|
|
env <- readIORef c
|
|
let
|
|
w' = T.pack w
|
|
words = Set.toList $ Set.filter ((w' `T.isPrefixOf`) . getNameText) (definedNames env)
|
|
pure (map (simpleCompletion . T.unpack . getNameText) words)
|
|
|
|
loop :: ElabEnv -> IORef ElabEnv -> InputT IO ()
|
|
loop env envvar = do
|
|
inp <- fmap T.pack <$> getInputLine "% "
|
|
case inp of
|
|
Nothing -> pure ()
|
|
Just inp | ":r" `T.isPrefixOf` inp -> reload env envvar
|
|
Just inp ->
|
|
case runAlex (Bsl.fromStrict (T.encodeUtf8 inp)) parseRepl of
|
|
Left e -> do
|
|
liftIO $ print e
|
|
loop env envvar
|
|
Right st -> do
|
|
env <- liftIO $
|
|
runElab (checkStatement st ask) env
|
|
`catch` \e -> do
|
|
displayExceptions' inp (e :: SomeException)
|
|
pure env
|
|
|
|
metas <- liftIO $ atomicModifyIORef' (unsolvedMetas env) (\x -> (mempty, x))
|
|
unless (Map.null metas) $ do
|
|
liftIO $ reportUnsolved (Just inp) metas
|
|
|
|
liftIO $ writeIORef envvar env
|
|
loop env envvar
|
|
|
|
reload :: ElabEnv -> IORef ElabEnv -> InputT IO ()
|
|
reload env@ElabEnv{loadedFiles} envref = do
|
|
newe <- liftIO $ try $ mkrepl <$> checkFiles (reverse loadedFiles)
|
|
case newe of
|
|
Left e -> do
|
|
liftIO $ displayExceptions' ":r" (e :: SomeException)
|
|
loop env envref
|
|
Right newe -> do
|
|
liftIO $ writeIORef envref newe
|
|
loop newe envref
|
|
|
|
checkFiles :: [String] -> IO ElabEnv
|
|
checkFiles files = runElab (go 1 files ask) =<< emptyEnv where
|
|
size = length files
|
|
sl = length (show size)
|
|
|
|
pad s
|
|
| length s < sl = replicate (sl - length s) ' ' ++ s
|
|
| otherwise = s
|
|
|
|
go _ [] k = do
|
|
env <- ask
|
|
for_ (Map.toList (nameMap env)) \case
|
|
(_, v@Defined{})
|
|
| Set.member v (definedNames env) -> pure ()
|
|
| otherwise ->
|
|
let
|
|
pos = fromJust (Map.lookup v (whereBound env))
|
|
in withSpan (fst pos) (snd pos) $ throwElab $ Elab.DeclaredUndefined v
|
|
_ -> pure ()
|
|
|
|
metas <- liftIO $ atomicModifyIORef' (unsolvedMetas env) (\x -> (mempty, x))
|
|
unless (Map.null metas) $ do
|
|
liftIO $ reportUnsolved Nothing metas
|
|
k
|
|
|
|
go n (x:xs) k = do
|
|
liftIO . putStrLn $ "[" ++ pad (show n) ++ "/" ++ show size ++ "] Loading " ++ x
|
|
code <- liftIO $ Bsl.readFile x
|
|
case runAlex (code <> Bsl.singleton 10) parseProg of
|
|
Left e -> liftIO $ print e *> error (show e)
|
|
Right prog ->
|
|
local (\e -> e { currentFile = Just (T.pack x), loadedFiles = x:loadedFiles e }) (checkProgram prog (go (n + 1 :: Int) xs k))
|
|
`catchElab` \e -> liftIO $ displayAndDie (T.decodeUtf8 (Bsl.toStrict code)) (e :: SomeException)
|
|
|
|
dumpEnv :: ElabEnv -> IO ()
|
|
dumpEnv env = for_ (Map.toList (nameMap env)) $ \(_, name) ->
|
|
let nft = fst $ getEnv env Map.! name in
|
|
Lt.putStrLn $ render (pretty name <+> nest (negate 1) (colon <+> align (prettyTm (quote (zonk nft)))))
|
|
|
|
parser :: ParserInfo Opts
|
|
parser = info (subparser (load <> check <> repl) <|> pure Repl <**> helper) (header "cubical - a cubical programming language")
|
|
where
|
|
load = command "load" $
|
|
info ((Load <$> (some (argument str (metavar "file...")))
|
|
<*> (many (strOption (long "eval" <> short 'e' <> help "Also evaluate this expression"))))
|
|
<**> helper) (progDesc "Check and load a list of files in the REPL")
|
|
|
|
repl = command "load" $
|
|
info ((Load <$> (many (argument str (metavar "file...")))
|
|
<*> (many (strOption (long "eval" <> short 'e' <> help "Also evaluate this expression"))))
|
|
<**> helper) (progDesc "Enter the REPL, optionally with loaded files")
|
|
|
|
check = command "check" $
|
|
info ((Check <$> some (argument str (metavar "file..."))
|
|
<*> switch ( long "verbose"
|
|
<> short 'v'
|
|
<> help "Print the types of all declared/defined values"))
|
|
<**> helper)
|
|
(progDesc "Check a list of files")
|
|
|
|
data Opts
|
|
= Load { files :: [String], eval :: [String] }
|
|
| Check { files :: [String], verbose :: Bool }
|
|
| Repl
|
|
deriving (Eq, Show, Ord)
|
|
|
|
displayAndDie :: Exception e => Text -> e -> IO a
|
|
displayAndDie lines e = do
|
|
() <- throwIO e `catches` displayExceptions lines
|
|
exitFailure
|
|
|
|
displayExceptions :: Text -> [Handler ()]
|
|
displayExceptions lines =
|
|
[ Handler \(WhileChecking a b e) -> do
|
|
T.putStrLn $ squiggleUnder a b lines
|
|
displayExceptions' lines e
|
|
, Handler \(SeeAlso a b e) -> do
|
|
displayExceptions' lines e
|
|
T.putStrLn $ squiggleUnder a b lines
|
|
, Handler \(AttachedNote n e) -> do
|
|
displayExceptions' lines e
|
|
Lt.putStrLn $ "\x1b[1;32mnote\x1b[0m: " <> render n
|
|
, Handler \(WhenCheckingEndpoint dir le ri ep e) -> do
|
|
displayExceptions' lines e
|
|
let
|
|
endp = case ep of
|
|
VI0 -> Lt.pack "left"
|
|
VI1 -> Lt.pack "right"
|
|
_ -> render . prettyTm $ quote ep
|
|
left = render (prettyTm (quote le))
|
|
right = render (prettyTm (quote ri))
|
|
Lt.putStrLn . Lt.unlines $
|
|
[ "\n\x1b[1;32mnote\x1b[0m: This path was expected to fill the diagram <<"
|
|
, "\t " <> redact left <> " " <> Lt.replicate 7 (Lt.singleton '\x2500') <> " " <> redact right
|
|
, " >> in the direction " <> render (pretty dir) <> ", but the " <> endp <> " endpoint is incorrect"
|
|
]
|
|
, Handler \(NotEqual ta tb) -> do
|
|
Lt.putStrLn . render . vsep $
|
|
[ "\x1b[1;31merror\x1b[0m: Mismatch between actual and expected types:"
|
|
, indent 2 $ "* \x1b[1mActual\x1b[0m:" <> softline <> align (prettyVl (zonk ta))
|
|
, indent 2 $ "* \x1b[1mExpected\x1b[0m:" <> softline <> align (prettyVl (zonk tb))
|
|
]
|
|
, Handler \(NoSuchPrimitive x) -> do
|
|
putStrLn $ "Unknown primitive: " ++ T.unpack x
|
|
, Handler \(NotInScope x) -> do
|
|
putStrLn $ "Variable not in scope: " ++ show (pretty x)
|
|
, Handler \(Elab.DeclaredUndefined n) -> do
|
|
putStrLn $ "Name declared but not defined: " ++ show (pretty n)
|
|
, Handler \Elab.PathConPretype -> do
|
|
putStrLn $ "Pretypes can not have path constructors, either change this definition so it lands in Type or remove it."
|
|
]
|
|
|
|
redact :: Lt.Text -> Lt.Text
|
|
redact x
|
|
| length (Lt.lines x) >= 2 = head (Lt.lines x) <> Lt.pack "\x1b[1;32m[...]\x1b[0m"
|
|
| otherwise = x
|
|
|
|
reportUnsolved :: Foldable t => Maybe Text -> Map.Map MV (t (Seq Projection, Value)) -> IO ()
|
|
reportUnsolved code metas = do
|
|
for_ (Map.toList metas) \(m, p) -> do
|
|
case mvSpan m of
|
|
Just (f, s, e) ->
|
|
case code of
|
|
Just code -> T.putStrLn $ squiggleUnder s e code
|
|
Nothing -> T.putStrLn . squiggleUnder s e =<< T.readFile (T.unpack f)
|
|
Nothing -> pure ()
|
|
|
|
case null p of
|
|
True -> do
|
|
Lt.putStrLn . render $ "Unsolved metavariable" <+> prettyTm (Meta m) <+> pretty ':' <+> align (prettyVl (zonk (mvType m)) <> pretty '.')
|
|
_ -> do
|
|
Lt.putStrLn . render $
|
|
"Unsolved metavariable" <+> prettyTm (Meta m) <+> pretty ':' <+> align (prettyVl (zonk (mvType m)) <+> "should satisfy:")
|
|
for_ p \p ->
|
|
Lt.putStrLn . render $ indent 2 $ prettyTm (quote (zonk (VNe (HMeta m) (fst p)))) <+> pretty '≡' <+> prettyTm (quote (snd p))
|
|
|
|
when (mvInteraction m && not (Map.null (mvContext m))) do
|
|
putStrLn "Context (first 10 entries):"
|
|
for_ (take 10 (Map.toList (mvContext m))) \(x, t) -> unless (isIdkT t) do
|
|
Lt.putStrLn . render $ indent 2 $ pretty x <+> pretty ':' <+> prettyVl (zonk t)
|
|
|
|
displayExceptions' :: Exception e => Text -> e -> IO ()
|
|
displayExceptions' lines e = displayAndDie lines e `catch` \(_ :: ExitCode) -> pure ()
|
|
|
|
squiggleUnder :: Posn -> Posn -> Text -> Text
|
|
squiggleUnder (Posn l c) (Posn l' c') file
|
|
| l == l' =
|
|
let
|
|
line = T.pack (show l) <> " | " <> T.lines file !! (l - 1)
|
|
padding = T.replicate (length (show l)) (T.singleton ' ') <> " |"
|
|
squiggle = T.replicate c " " <> T.pack "\x1b[1;31m" <> T.replicate (c' - c) "~" <> T.pack "\x1b[0m"
|
|
|
|
in T.unlines [ padding, line, padding <> squiggle ]
|
|
| otherwise = T.unlines (take (l' - l) (drop l (T.lines file)))
|
|
|
|
dumpTokens :: Alex ()
|
|
dumpTokens = do
|
|
t <- alexMonadScan
|
|
case tokenClass t of
|
|
TokEof -> pure ()
|
|
_ -> do
|
|
traceDocM (viaShow t)
|
|
dumpTokens
|