{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

module Main where

import Boilerplate.ConfigParser
import Boilerplate.Doc
import Boilerplate.GhcParser
import Boilerplate.Interpreter
import Boilerplate.RuleFinder
import Boilerplate.RuleParser
import Boilerplate.Types
#if MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)
import qualified GHC.Version as GHC
#else
import qualified Config as GHC
#endif
import Control.Monad (when)
import Data.IORef (modifyIORef')
import Data.IORef (readIORef)
import Data.IORef (newIORef)
import Data.List (isPrefixOf)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Maybe (mapMaybe)
import Data.Maybe (catMaybes)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import HsInspect.Types (Comment(..), Pos(..), Type(..))
import System.Environment (getArgs)
import System.Exit (ExitCode(..), exitWith)
import System.IO (stderr)
import System.IO (hPutStrLn)
import Text.Parsec (parse, setPosition)
import Text.Parsec.Pos (newPos)
import Text.Parsec.Text (parseFromFile)

version :: String
#ifdef CURRENT_PACKAGE_VERSION
version = CURRENT_PACKAGE_VERSION
#else
version = "unknown"
#endif

help :: String
help =
  "boilerplate [GLOBAL FLAGS] FILE\n\n" ++
  "Global flags:\n\n" ++
  " -h,--help               Show this help text\n" ++
  " -v,--version            Print version information\n" ++
  "    --ghc-version        Print ghc version information\n" ++
  " -i,--inplace            Overwrite FILE in place\n" ++
  "    --verbose            Print debugging information to stderr\n" ++
  "    --check-rule         Parse FILE as a rule file and display errors\n"

-- TODO automatic imports
--
-- rules could declare imports they probably need quite easily, but figuring out
-- if an import is necessary (especially considering reexports) and making a
-- diff to the import section is very difficult and probably warrants its own
-- tool. Nevertheless, this would be an excellent feature.

main :: IO ()
main = do
  args <- getArgs
  let hasAny :: Eq a => [a] -> [a] -> Bool
      hasAny [] _ = False
      hasAny _ [] = False
      hasAny as (x : xs) | elem x as = True
                         | otherwise = hasAny as xs

  when (hasAny ["-h", "--help"] args) $
    (putStrLn help) >> exitWith ExitSuccess
  when (hasAny ["-v", "--version"] args) $
    (putStrLn version) >> exitWith ExitSuccess
  when (elem "--ghc-version" args) $
    (putStrLn GHC.cProjectVersion) >> exitWith ExitSuccess

  let exit1 msg = (hPutStrLn stderr msg) >> (exitWith $ ExitFailure 1)

  when (null args) $ exit1 "missing arguments"

  let inplace = hasAny ["-i", "--inplace"] args
      file = last $ filter (not . isPrefixOf "-") args
      verbose = elem "--verbose" args

  -- TODO all parsec errors should be formatted as path/to/file.hs:line:col:

  when (elem "--check-rule" args) $ do
    parsed <- parseFromFile ruleParser file
    case parsed of
      Left err -> exit1 $ show err
      Right _ -> exitWith ExitSuccess

  content <- T.readFile file

  -- early exit when there is no work to do
  when (not $ T.isInfixOf "BOILERPLATE" content) $
    if inplace
    then exitWith ExitSuccess
    else (T.putStr content) >> exitWith ExitSuccess

  (types, comments) <- parseHaskell file

  let parseComment (Comment txt (Pos line col) end) =
        case parse (setPosition (newPos file line col) *> configCommentParser) file txt of
        Left msg -> do
          when (verbose && T.isInfixOf "BOILERPLATE" txt) $ do
            hPutStrLn stderr $ show msg
          pure $ Nothing
        Right c -> pure $ Just (c, end)

  configs <- catMaybes <$> traverse parseComment comments
  let targets = flip mapMaybe (threes configs) $ \case
        (One   ((Config t r c), s)) -> Just $ Action t r c s Nothing
        (Two   ((Config t r c), s) _) -> Just $ Action t r c s Nothing
        -- the ConfigStart is irrelevant for position detection, it is
        -- to make it easier for text editors to hide expansions.
        (Three ((Config t r c), s) (ConfigStart, _) (ConfigEnd, e)) -> Just $ Action t r c s (Just e)
        (Three ((Config t r c), s) _ _) -> Just $ Action t r c s Nothing
        _ -> Nothing

  ruleFiles <- findRules file

  when verbose $ do
    hPutStrLn stderr $ show types
    hPutStrLn stderr $ show targets
    hPutStrLn stderr $ show ruleFiles

  rulesCache <- newIORef M.empty

  let
    findRule :: Text -> IO Rule
    findRule rulename = do
      let pickRule (fqn, short, path) =
            if fqn == rulename || short == rulename
            then Just path
            else Nothing
      case mapMaybe pickRule ruleFiles of
        [] -> exit1 "no rules"
        [ruleFile] -> do
          cached <- readIORef rulesCache
          case M.lookup ruleFile cached of
            Nothing -> do
              parsed <- parseFromFile ruleParser ruleFile
              case parsed of
                Left err -> exit1 $ show err
                Right r -> r <$ modifyIORef' rulesCache (M.insert ruleFile r)
            Just hit -> do
              when verbose $
                hPutStrLn stderr $ "hit cache for " <> ruleFile
              pure hit
        many -> exit1 $ "ambiguous rules" <> show many

    tpes :: Map Text Type
    tpes = M.fromList $ (\t -> (tycon t, t)) <$> types
      where
        tycon = \case
          ProductType tc _ _ _ _ -> tc
          RecordType tc _ _ _ _ -> tc
          SumType tc _ _ -> tc

    resolve (Action tycon rulenames custom start end) = do
      tpe <- case M.lookup tycon tpes of
        Nothing -> exit1 $ "could not find the type definition for " <> show tycon
        Just a -> pure a
      rules' <- traverse findRule rulenames
      pure $ Action tpe rules' custom start end

  resolved <- traverse resolve targets

  when verbose $ do
    hPutStrLn stderr $ show resolved

  let
    interpret (Action tpe rules cus start end) =
      (\txt -> (start, end, prepare $ T.unlines txt)) <$>
        (traverse (\r -> interpretRule r tpe (M.fromList cus)) rules)
    interpreted = traverse interpret resolved
    prepare snippet = start_comment <> T.strip snippet <> end_comment
    start_comment = "\n{- BOILERPLATE START -}\n"
    end_comment = "\n{- BOILERPLATE END -}"

  replacement <- unDoc <$> case interpreted of
    Left err -> exit1 $ T.unpack err
    Right good -> pure $ upsertMany (mkDoc content) good

  if inplace
  then T.writeFile file replacement
  else T.putStr replacement

data Three a = One a | Two a a | Three a a a

threes :: [a] -> [Three a]
threes = \case
  [] -> []
  [a] -> [One a]
  a1 : a2 : [] -> Two a1 a2 : (threes [a2])
  a1 : a2 : a3 : as -> Three a1 a2 a3 : (threes $ a2 : a3 : as)

type Target = Action Text Text
type Resolved = Action Type Rule

data Action tpe rule = Action tpe [rule] [(Text, Custom)] Pos (Maybe Pos)
  deriving (Eq, Show)