module Main where

import Control.Monad (forM_)
import Control.Monad.Identity (Identity)
import Control.Monad.Writer
import Data.Aeson (Value (Null), encode)
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.Data (cast)
import qualified Data.Text as Text
import qualified Data.Text.IO
import Data.Typeable
import GHC.IO.Exception (ExitCode (ExitFailure, ExitSuccess))
import Language.Fiddle.Ast
import Language.Fiddle.Compiler
import Language.Fiddle.Compiler.ConsistencyCheck
import Language.Fiddle.Compiler.Expansion
import Language.Fiddle.Compiler.ImportResolution
import Language.Fiddle.Compiler.Stage0
import Language.Fiddle.GenericTree (GenericSyntaxTree (..), ToGenericSyntaxTree (toGenericSyntaxTree), alterGenericSyntaxTree)
import qualified Language.Fiddle.Parser
import qualified Language.Fiddle.Tokenizer
import Options.Applicative
import qualified System.Environment as System
import System.Exit (exitWith)

compilationPipeline =
  importResolutionPhase >>> expansionPhase >>> consistencyCheckPhase

newtype GlobalFlags
  = GlobalFlags
  { flagsInputFile :: String
  }

parseGlobalFlags :: Parser GlobalFlags
parseGlobalFlags =
  GlobalFlags
    <$> argument str (metavar "INPUT" <> help "Input file")

main :: IO ()
main = do
  (globalFlags, compilationPipelineAction) <-
    execParser $
      info
        ( ( (,)
              <$> parseGlobalFlags
              <*> execCompilationPipelineWithCmdline compilationPipeline
          )
            <**> helper
        )
        ( fullDesc
            <> progDesc "Compile Fiddle Files"
            <> header "fiddlec -  A compiler for fiddle files"
        )

  let filePath = flagsInputFile globalFlags
  text <- Data.Text.IO.readFile filePath

  let maybeParsedAst = compile_ $ toStage0 filePath text >>= toStage1
  case maybeParsedAst of
    (priorDiags, Just ast) -> do
      ((priorDiags ++) -> diags, ma) <- compilationPipelineAction ast
      ec <-
        case ma of
          Just ast -> do
            putStrLn $
              BL.unpack $
                encode $
                  alterGenericSyntaxTree cleanupIdentifiers $
                    toGenericSyntaxTree $
                      fmap
                        (const (Nothing :: Maybe Value))
                        ast
            return ExitSuccess
          Nothing -> do
            putStrLn "\x1b[1;31mCompilation Failed\x1b[0m"
            return (ExitFailure 1)

      forM_ diags printDiagnostic
      exitWith ec
    (diags, _) -> do
      putStrLn "\x1b[1;31mParsing Failed\x1b[0m"
      forM_ diags printDiagnostic
      exitWith (ExitFailure 1)

cleanupIdentifiers :: GenericSyntaxTree Identity a -> Maybe (GenericSyntaxTree Identity a)
cleanupIdentifiers (SyntaxTreeObject _ _ _ tr)
  | (Just (Identifier n _)) <- castT tr =
      Just $ SyntaxTreeValue (Text.unpack n)
  where
    castT ::
      (Typeable t, Typeable f, Typeable a, Typeable t') =>
      t f a ->
      Maybe (t' f a)
    castT = cast
cleanupIdentifiers _ = Nothing