{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances,
    ScopedTypeVariables, CPP #-}

import Text.Printf
import System.Exit
import qualified Control.Exception as E
import Text.Pandoc (Block(..), Inline(..), Format(..), bottomUp,
   nullMeta, Pandoc(..))
import Text.CSL.Compat.Pandoc (writeHtmlString)
import Data.Char (isSpace, toLower)
import System.Environment (getArgs)
import System.Process
import System.IO.Temp (withSystemTempDirectory)
import qualified Text.Pandoc.UTF8 as UTF8
import Data.Aeson
import Data.Aeson.Types (Parser)
import System.FilePath
import System.Directory
import Data.List (sort, isInfixOf)
import qualified Data.Map as M
import Text.CSL.Style hiding (Number)
import Text.CSL.Reference
import Text.CSL
import Control.Monad
import qualified Data.ByteString.Lazy as BL

data TestCase = TestCase{
    testMode          :: Mode        -- mode
  , testBibopts       :: BibOpts     -- bibsection
  , testCitations     :: [CiteObject] -- citations
  , testCitationItems :: Citations   -- citation-items
  , testCsl           :: Style       -- csl
  , testAbbreviations :: Abbreviations -- abbreviations
  , testReferences    :: [Reference] -- input
  , testResult        :: String      -- result
  } deriving (Show)

data Mode = CitationMode
          | CitationRTFMode
          | BibliographyMode
          | BibliographyHeaderMode
          | BibliographyNoSortMode
          deriving Show

instance FromJSON Mode where
  parseJSON (String "citation")     = return CitationMode
  parseJSON (String "citation-rtf") = return CitationRTFMode
  parseJSON (String "bibliography") = return BibliographyMode
  parseJSON (String "bibliography-header") = return BibliographyHeaderMode
  parseJSON (String "bibliography-nosort") = return BibliographyNoSortMode
  parseJSON _                       = fail "Unknown mode"

instance FromJSON TestCase where
  parseJSON (Object v) = TestCase <$>
              v .:  "mode" <*>
              v .:? "bibsection" .!= Select [] [] <*>
              ((v .: "citations") >>= parseCitations) <*>
              v .:? "citation_items" .!= [] <*>
              (parseCSL <$> (v .: "csl")) <*>
              v .:? "abbreviations" .!= (Abbreviations M.empty) <*>
              v .:  "input" <*>
              v .:  "result"
        where parseCitations :: Data.Aeson.Value -> Parser [CiteObject]
              parseCitations x@(Array{}) = parseJSON x
              parseCitations _           = return []
  parseJSON _ = fail "Could not parse test case"

newtype CiteObject =
        CiteObject { unCiteObject :: [Cite] } deriving Show

instance FromJSON CiteObject where
  parseJSON (Array v) =
    case fromJSON (Array v) of
         Success [Object x, Array _, Array _] ->
                            CiteObject <$> x .: "citationItems"
         Error e         -> fail $ "Could not parse CiteObject: " ++ e
         x               -> fail $ "Could not parse CiteObject" ++ show x
  parseJSON x = fail $ "Could not parse CiteObject " ++ show x

#if MIN_VERSION_aeson(0,10,0)
#else
instance FromJSON [CiteObject] where
  parseJSON (Array v) = mapM parseJSON $ V.toList v
  parseJSON _ = return []
#endif

data TestResult =
    Passed
  | Skipped
  | Failed
  | Errored
  deriving (Show, Eq)

testDir :: FilePath
testDir = "citeproc-test" </> "processor-tests" </> "machines"

handler :: FilePath -> E.SomeException -> IO TestResult
handler path e = do
  putStrLn $ "[ERROR] " ++ path ++ "\n" ++ show e
  return Errored

runTest :: FilePath -> IO TestResult
runTest path = E.handle (handler path) $ do
  raw <- BL.readFile path
  let testCase = either error id $ eitherDecode raw
  let procOpts' = ProcOpts (testBibopts testCase) False
  style <- localizeCSL Nothing
           $ (testCsl testCase) { styleAbbrevs = testAbbreviations testCase }
  let refs     = testReferences testCase
  let cites    = map unCiteObject (testCitations testCase) ++ testCitationItems testCase
  let cites'   = if null cites
                    then [map (\ref -> emptyCite{ citeId = unLiteral $ refId ref}) refs]
                    else cites
  let expected = adjustEntities $ fixBegins $ trimEnd $ testResult testCase
  let mode     = testMode testCase
  let assemble BibliographyMode xs =
         "<div class=\"csl-bib-body\">\n" ++
         unlines (map (\x -> "  <div class=\"csl-entry\">" ++ x ++
                               "</div>") xs) ++ "</div>\n"
      assemble _ xs = unlines xs
  case mode of
       BibliographyHeaderMode  -> do
          putStrLn $ "[SKIPPED] " ++ path ++ "\n"
          return Skipped
       BibliographyNoSortMode  -> do
          putStrLn $ "[SKIPPED] " ++ path ++ "\n"
          return Skipped
       _ -> do
         let result   = assemble mode
              $ map (inlinesToString . renderPandoc style) $
                (case mode of {CitationMode -> citations; _ -> bibliography})
                $ citeproc procOpts' style refs cites'
         if result == expected
            then do
              putStrLn $ "[PASSED] " ++ path ++ "\n"
              return Passed
            else do
              putStrLn $ "[FAILED] " ++ path
              showDiff expected result
              putStrLn ""
              return Failed

trimEnd :: String -> String
trimEnd = reverse . ('\n':) . dropWhile isSpace . reverse

-- this is designed to mimic the test suite's output:
inlinesToString  :: [Inline]  -> String
inlinesToString ils =
  writeHtmlString
    $ bottomUp (concatMap adjustSpans)
    $ Pandoc nullMeta [Plain ils]

-- We want &amp; instead of &#38; etc.
adjustEntities :: String -> String
adjustEntities ('&':'#':'3':'8':';':xs) = "&amp;" ++ adjustEntities xs
adjustEntities (x:xs) = x : adjustEntities xs
adjustEntities []     = []

-- citeproc-js test suite expects "citations" to be formatted like
-- .. [0] Smith (2007)
-- >> [1] Jones (2008)
-- To get a meaningful comparison, we remove this.
fixBegins :: String -> String
fixBegins = unlines . map fixLine . lines
  where fixLine ('.':'.':'[':xs) = dropWhile isSpace $ dropWhile (not . isSpace) xs
        fixLine ('>':'>':'[':xs) = dropWhile isSpace $ dropWhile (not . isSpace) xs
        fixLine xs = xs

-- adjust the spans so we fit what the test suite expects.
adjustSpans :: Inline -> [Inline]
adjustSpans (Note [Para xs]) = xs
adjustSpans (Link _ ils _) = ils
adjustSpans (Span ("",[],[]) xs) = xs
adjustSpans (Span ("",["nocase"],[]) xs) = xs
adjustSpans (Span ("",["citeproc-no-output"],[]) _) =
  [Str "[CSL STYLE ERROR: reference with no printed form.]"]
adjustSpans (Span (id',classes,kvs) ils) =
  [Span (id',classes',kvs') ils]
  where classes' = filter (`notElem` ["csl-no-emph","csl-no-strong","csl-no-smallcaps"]) classes
        kvs' = if null styles then kvs else (("style", concat styles) : kvs)
        styles = ["font-style:normal;" | "csl-no-emph" `elem` classes]
              ++ ["font-weight:normal;" | "csl-no-strong" `elem` classes]
              ++ ["font-variant:normal;" | "csl-no-smallcaps" `elem` classes]
adjustSpans (Emph xs) =
  RawInline (Format "html") "<i>" : xs ++ [RawInline (Format "html") "</i>"]
adjustSpans (Strong xs) =
  RawInline (Format "html") "<b>" : xs ++ [RawInline (Format "html") "</b>"]
adjustSpans (SmallCaps xs) =
  RawInline (Format "html") "<span style=\"font-variant:small-caps;\">" : xs ++ [RawInline (Format "html") "</span>"]
adjustSpans x = [x]

showDiff :: String -> String -> IO ()
showDiff expected' result' =
  withSystemTempDirectory "test-pandoc-citeproc-XXX" $ \fp -> do
    let expectedf = fp </> "expected"
    let actualf   = fp </> "actual"
    UTF8.writeFile expectedf expected'
    UTF8.writeFile actualf result'
    withDirectory fp $ void $ rawSystem "diff" ["-u","expected","actual"]

withDirectory :: FilePath -> IO a -> IO a
withDirectory fp action = do
    oldDir <- getCurrentDirectory
    setCurrentDirectory fp
    result <- action
    setCurrentDirectory oldDir
    return result

main :: IO ()
main = do
  args <- getArgs
  let matchesPattern x
        | null args = True
        | otherwise = any (`isInfixOf` (map toLower x))
                        (map (map toLower . takeBaseName) args)
  exists <- doesDirectoryExist testDir
  unless exists $ do
    putStrLn "Downloading test suite"
    _ <- rawSystem "git" ["clone", "https://github.com/citation-style-language/test-suite.git", "citeproc-test"]
    withDirectory "citeproc-test" $
      void $ rawSystem "python" ["processor.py", "--grind"]

  testFiles <- if any ('/' `elem`) args
               then return args
               else (map (testDir </>) . sort .
                  filter matchesPattern .
                  filter (\f -> takeExtension f == ".json"))
                 <$> getDirectoryContents testDir
  results <- mapM runTest testFiles
  let numpasses  = length $ filter (== Passed) results
  let numskipped = length $ filter (== Skipped) results
  let numfailures = length $ filter (== Failed) results
  let numerrors = length $ filter (== Errored) results
  putStrLn $ show numpasses ++ " passed; " ++ show numfailures ++
              " failed; " ++ show numskipped ++ " skipped; " ++
              show numerrors ++ " errored."
  let summary = unlines $ zipWith (\fp res -> printf "%-10s %s" (show res) fp) testFiles results
  when (null args) $ do -- write log if complete test suite run
    ex <- doesFileExist "test-citeproc.log"
    when ex $ do
      putStrLn "Copying existing test-citeproc.log to test-citeproc.log.old"
      copyFile "test-citeproc.log" "test-citeproc.log.old"
    putStrLn "Writing test-citeproc.log."
    UTF8.writeFile "test-citeproc.log" summary
  exitWith $ if numfailures == 0
                then ExitSuccess
                else ExitFailure $ numfailures + numerrors