{-# 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
import qualified Config as GHC
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 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"

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

  when (null args) $
    (putStrLn "missing arguments") >> (exitWith $ ExitFailure 1)

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

  -- FIXME a --check-rule flag that just parses a rule

  content <- T.readFile file

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

  -- 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
        [] -> error "no rules"
        [ruleFile] -> do
          cached <- readIORef rulesCache
          case M.lookup ruleFile cached of
            Nothing -> do
              parsed <- parseFromFile ruleParser ruleFile
              case parsed of
                Left err -> error $ 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 -> error $ "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 -> error $ "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 -> (putStrLn $ T.unpack err) >> (exitWith $ ExitFailure 1)
    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)