You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
111 lines
3.2 KiB
111 lines
3.2 KiB
-- {-# LANGUAGE BlockArguments #-}
|
|
module Main where
|
|
|
|
import Control.Monad ( unless )
|
|
|
|
import qualified Data.ByteString.Lazy as Lbs
|
|
import qualified Data.Text.Encoding as T
|
|
import qualified Data.Text as T
|
|
import Data.Foldable
|
|
|
|
import Debug.Trace
|
|
|
|
import Frontend.Autogen.Parser
|
|
import Frontend.Autogen.Lexer
|
|
import Frontend.Lexer.Wrapper
|
|
import Frontend.Lexer.Tokens
|
|
|
|
import System.Environment (getArgs)
|
|
|
|
import Text.Show.Pretty (pPrint)
|
|
import Frontend.Parser.Posn
|
|
import System.Posix.Internals
|
|
import GHC.IO.Handle.FD (stdout, handleToFd)
|
|
import GHC.IO.FD
|
|
import Data.Maybe (fromMaybe)
|
|
|
|
main :: IO ()
|
|
main = do
|
|
args <- getArgs
|
|
for_ args $ \str -> do
|
|
Main.lex str pPrint parseMod =<< Lbs.readFile str
|
|
|
|
testParse :: String -> IO ()
|
|
testParse s = Main.lex "<interactive>" pPrint parseMod (Lbs.fromStrict (T.encodeUtf8 (T.pack s)))
|
|
|
|
testLex :: String -> IO ()
|
|
testLex s = Main.lex "<interactive>" (const (pure ())) (scan []) (Lbs.fromStrict (T.encodeUtf8 (T.pack s)))
|
|
|
|
lex :: String -> (a -> IO ()) -> Alex a -> Lbs.ByteString -> IO ()
|
|
lex fname show cont arg = do
|
|
let
|
|
x = runAlex fname arg cont
|
|
color <- fmap (1 ==) . c_isatty . fdFD =<< handleToFd GHC.IO.Handle.FD.stdout
|
|
code <- if fname == "<interactive>"
|
|
then pure . lines $ T.unpack (T.decodeUtf8 (Lbs.toStrict arg))
|
|
else lines <$> readFile fname
|
|
case x of
|
|
Left e -> putStr $ showParseError color code e
|
|
Right x -> show x
|
|
|
|
printParseError :: ParseError -> IO ()
|
|
printParseError pe = do
|
|
code <- lines <$> readFile (parseErrorFilename pe)
|
|
color <- fmap (1 ==) . c_isatty . fdFD =<< handleToFd GHC.IO.Handle.FD.stdout
|
|
putStr $ showParseError color code pe
|
|
|
|
showParseError :: Bool -> [String] -> ParseError -> String
|
|
showParseError color code pe = do
|
|
let
|
|
linum = posnLine (parseErrorBegin pe)
|
|
startcol = posnColm (parseErrorBegin pe)
|
|
|
|
multiline = linum /= posnLine (parseErrorEnd pe)
|
|
|
|
width
|
|
| multiline = 0
|
|
| otherwise = max 0 (posnColm (parseErrorEnd pe) - startcol - 1)
|
|
|
|
linum' = show linum
|
|
|
|
line = [ show linum ++ sep ++ code !! (linum - 1) | linum <- [ linum .. posnLine (parseErrorEnd pe) ] ]
|
|
|
|
padding = replicate (length linum') ' ' ++ sep
|
|
padding' = replicate (length linum') ' ' ++ " "
|
|
|
|
caret = replicate (startcol - 1) ' ' ++ red ++ "^"
|
|
squiggle = replicate width '~'
|
|
|
|
(red, bold, reset, sep)
|
|
| color = ("\x1b[31m", "\x1b[1m", "\x1b[0m", "\x1b[1;34m \9474 \x1b[0m")
|
|
| otherwise = ("", "", "", "")
|
|
|
|
unlines $
|
|
[ bold
|
|
++ parseErrorFilename pe
|
|
++ ":" ++ show linum ++ ":" ++ show startcol ++ ": "
|
|
++ red ++ "parse error:" ++ reset
|
|
|
|
, padding'
|
|
, init (unlines line)
|
|
, padding' ++ caret ++ squiggle ++ reset ++ fromMaybe "" ((" " ++) <$> parseErrorInlineDesc pe)
|
|
|
|
, ""
|
|
, padding' ++ parseErrorMessage pe
|
|
]
|
|
|
|
scan :: [Token] -> Alex [Token]
|
|
scan acc = do
|
|
tok <- alexMonadScan
|
|
sc <- alexGetStartCode
|
|
state <- getUserState
|
|
traceM . unlines $
|
|
[ "----------------"
|
|
, "just lexed: " ++ show tok
|
|
, "sc: " ++ show sc
|
|
, "sc stack: " ++ show (startCodes state)
|
|
, "layout stack: " ++ show (layoutColumns state)
|
|
]
|
|
case tokenClass tok of
|
|
TokEof -> pure (reverse acc)
|
|
_ -> scan (tok:acc)
|