{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

import Control.RTree

import ReduceC

import Colog
import Control.Applicative
import Control.Monad
import Control.Monad.Trans
import Data.Foldable
import Data.Functor
import Data.Map.Strict qualified as Map
import Data.Text qualified as Text
import GHC.Stack
import Language.C qualified as C
import Options.Applicative
import System.Directory
import System.Exit
import System.FilePath
import System.IO
import System.Process.Typed
import Text.Pretty.Simple
import Text.PrettyPrint qualified as P
import Prelude hiding (log)

main :: IO ()
main =
  join
    . execParser
    $ info (run <**> helper)
    . fold
    $ []

process :: (WithLog env (Msg sev) m, MonadIO m) => sev -> Text.Text -> m a -> m a
process sev p ma = do
  msg "Started "
  a <- ma
  msg "Done "
  pure a
 where
  s = withFrozenCallStack callStack
  msg t = Colog.logMsg (Msg sev s (t <> p))

run :: (HasCallStack) => Parser (IO ())
run = do
  file <- strArgument $ fold [metavar "FILE"]

  validity <-
    flag False True
      $ fold
        [ long "validity"
        , help "check for validity, throw error if command fails"
        ]

  expmode <-
    flag False True
      $ fold
        [ long "exp"
        , help "run in exponential mode"
        ]

  pure
    $ usingLoggerT (cmap fmtMessage logTextStdout)
    $ do
      let
        test f = process D ("test " <> Text.pack f) do
          err <- liftIO $ runProcess (proc "clang" ["-O0", file])
          log D (Text.pack $ show err)
          pure (err == ExitSuccess)

        output f c = process D ("writing " <> Text.pack f) do
          let x = P.render (C.pretty (c $> C.undefNode))
          liftIO $ writeFile f x

        check' f c = do
          when validity do
            liftIO $ copyFile file (file <.> "last")
          output f c
          t <- test f
          if t
            then pure True
            else do
              liftIO $ when validity do
                copyFile file (file <.> "fail")
                copyFile (file <.> "last") file
                exitFailure
              pure False

      let bak = file <.> "bak"

      process D "backing up file" do
        liftIO $ copyFile file bak

      process I "check predicate" do
        t <- test file
        unless t do
          liftIO exitFailure

      c <- process D "parsing file" do
        parseCFile file

      output file c

      process I "sanity checks" do
        c' <- parseCFile file
        unless (void c' == void c) do
          liftIO do
            withFile "error.1.hs" WriteMode (`pHPrint` void c)
            withFile "error.2.hs" WriteMode (`pHPrint` void c')
          logError "Outputted a different file than i read... Please report original file and error.{1,2}.hs"
          liftIO exitFailure

        t <- test file
        unless t do
          liftIO exitFailure

      l <-
        (if expmode then ireduceExp else ireduce)
          (check' file)
          (Map.singleton (C.internalIdent "main") True)
          (ReduceC.reduceC c)

      output file l
 where
  parseCFile file = do
    res <- liftIO $ C.parseCFilePre file
    case res of
      Right c -> pure c
      Left err -> do
        logError (Text.pack (show err))
        liftIO exitFailure