-- {-# 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 (\_ -> putStrLn $ str ++ " parsed!") 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)