|
|
- {-# LANGUAGE BlockArguments #-}
- {-# LANGUAGE OverloadedStrings #-}
- {-# LANGUAGE ScopedTypeVariables #-}
- module Main where
-
- import Control.Exception
-
- import qualified Data.ByteString.Lazy as Bsl
- import qualified Data.Text.Encoding as T
- import qualified Data.Map.Strict as Map
- import qualified Data.Text.IO as T
- import qualified Data.Text as T
- import Data.Text ( Text )
- import Data.Foldable
-
- import Elab.Monad
- import Elab.Eval
- import Elab
-
- import Presyntax.Presyntax (Posn(Posn))
- import Presyntax.Parser
- import Presyntax.Tokens
- import Presyntax.Lexer
-
- import System.Exit
- import Syntax.Pretty
-
- main :: IO ()
- main = do
- t <- Bsl.readFile "test.tt"
- let Right tks = runAlex t parseProg
- env <- runElab (checkProgram tks) emptyEnv `catch` \e -> displayAndDie (T.decodeUtf8 (Bsl.toStrict t)) (e :: SomeException)
- for_ (Map.toList (getEnv env)) $ \(n, x) -> putStrLn $ show n ++ " : " ++ showValue (zonk (fst x))
-
- 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 \(NotEqual ta tb) -> do
- putStrLn . unlines $
- [ "\x1b[1;31merror\x1b[0m: Mismatch between actual and expected types:"
- , " * \x1b[1mActual\x1b[0m: " ++ showValue (zonk ta)
- , " * \x1b[1mExpected\x1b[0m: " ++ showValue (zonk tb)
- ]
- ]
-
- 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.pack (show (Posn l c, Posn l' c'))
|