{-# LANGUAGE PatternGuards, CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Text.CSL.Test
-- Copyright   :  (c) Andrea Rossato
-- License     :  BSD-style (see LICENSE)
--
-- Maintainer  :  Andrea Rossato <andrea.rossato@unitn.it>
-- Stability   :  unstable
-- Portability :  unportable
--
-- A module for reading Frank's citeproc-js testsuite.
--
-----------------------------------------------------------------------------

module Text.CSL.Test
    ( toTest
    , runTS
    , test, test',test_
    , runTest
    , Test (..)
    ) where

import Control.Arrow
import Control.Monad.State
import Data.ByteString.Lazy.UTF8 ( fromString )
import Data.Char (toLower, chr)
import Data.List
import Data.Maybe (isJust)
import Data.Time
import System.Directory
import System.Locale

import Text.ParserCombinators.Parsec

import Text.JSON.Generic

import Text.CSL.Input.Json
import Text.CSL.Output.Pandoc
import Text.CSL.Output.Plain
import Text.CSL.Reference
import Text.CSL.Pickle ( readXmlString )
import Text.CSL.Parser ( xpStyle, xpLocale, langBase )
import Text.CSL.Proc
import Text.CSL.Style
import Text.Pandoc.Definition
#ifdef EMBED_DATA_FILES
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.UTF8 as U
import Text.CSL.Parser ( localeFiles )
#else
import System.IO.Unsafe
import Data.IORef
import Paths_citeproc_hs ( getDataFileName )
import Text.CSL.Parser ( readLocaleFile )
import Text.CSL.Pickle ( readXmlFile )
#endif

data Test
    = Test
      { testMode      :: String
      , testInput     :: [Reference]
      , testCSL       :: Style
      , testAbbrevs   :: [Abbrev]
      , testResult    :: String
      , testBibSect   :: BibOpts
      , testCitItems  :: Maybe Citations
      , testCitations :: Maybe Citations
      } deriving ( Show )

toTest :: JSValue -> Test
toTest ob = Test mode input style abbrevs result bibsection cites cites'
    where
      getObj f = case procJSObject f ob of
                   JSObject o -> fromJSObject o
                   _          -> error "error #217"
      object  = getObj id
      objectI = getObj editJsonInput
      objectC = getObj editJsonCiteItems

      look s = case lookup s object of
                 Just (JSString x) -> fromJSString x
                 _                 -> error $ "in test " ++ s ++ " section."
      style  = readXmlString xpStyle . fromString $ look "csl"
      mode   = look "mode"
      result = look "result"

      abbrevs  = case lookup "abbreviations" object of
                   Just o -> readJsonAbbrev o
                   _      -> []

      bibsection = case lookup "bibsection" objectI of
                     Just (JSObject o) -> getBibOpts $ fromJSObject o
                     _                 -> Select [] []

      cites  = case lookup "citation_items" objectC of
                 Just (JSArray cs) -> Just $ map readCite cs
                 _                 -> Nothing
      cites'  = case lookup "citations" objectC of
                 Just (JSArray cs) -> Just $ map readJsonCitations cs
                 _                 -> Nothing
      readCite c = case readJSData c of
                     Ok cite  -> cite
                     Error er -> error ("citationItems: " ++ er)

      refs r = case readJSData r of
                 Ok ref   -> ref
                 Error er -> error ("readJSData: " ++ er)

      input  = case lookup "input" objectI of
                 Just (JSArray ar) -> map refs ar
                 _                 -> error $ "in test input section."
      getFieldValue o
          | JSObject os <- o
          , [("field",JSString f),("value",JSString v)] <- fromJSObject os
                       = (fromJSString f, fromJSString v)
          | otherwise  = error "bibsection: could not parse fields and values"
      getBibOpts o = let getSec s = case lookup s o of
                                      Just (JSArray ar) -> map getFieldValue ar
                                      _                 -> []
                         select  = getSec "select"
                         include = getSec "include"
                         exclude = getSec "exclude"
                         quash   = getSec "quash"
                     in case () of
                          _ | select  /= [] -> Select  select  quash
                            | include /= [] -> Include include quash
                            | exclude /= [] -> Exclude exclude quash
                            | quash   /= [] -> Select  []      quash
                            | otherwise     -> Select  []      []

readTestFile :: FilePath -> IO JSValue
readTestFile f = do
  s <- readFile f
  let fields = ["CSL","RESULT","MODE","INPUT","CITATION-ITEMS","CITATIONS","BIBSECTION","BIBENTRIES", "ABBREVIATIONS"]
      format = map (toLower . \x -> if x == '-' then '_' else x)
  return . toJson . zip (map format fields) . map (fieldsParser s) $ fields

toJson :: [(String,String)] -> JSValue
toJson = JSObject . toJSObject . map getIt
    where
      getIt (s,j)
          | s `elem` ["result","csl","mode"] = (,) s . JSString $ toJSString j
          | s `elem` ["bibentries"]          = (,) s . JSBool   $ False
          | j == []                          = (,) s . JSBool   $ False
          | otherwise                        = (,) s . either error id . resultToEither $ decode j

fieldsParser :: String -> String -> String
fieldsParser s f = either (const []) id $ parse (fieldParser f) "" s

fieldParser :: String -> Parser String
fieldParser s = manyTill anyChar (try $ fieldMarkS) >>
                manyTill anyChar (try $ fieldMarkE)
    where
      fieldMarkS = string   ">>" >> many (oneOf "= ") >> string s >> many (oneOf "= ") >> string ">>\n"
      fieldMarkE = string "\n<<" >> many (oneOf "= ") >> string s >> many (oneOf "= ") >> string "<<\n"

pandocBib :: [String] -> String
pandocBib [] = []
pandocBib s
    = "<div class=\"csl-bib-body\">\n" ++
      concatMap (\x -> "  " ++ "<div class=\"csl-entry\">" ++ x ++ "</div>\n") s ++
      "</div>"

pandocToHTML :: [Inline] -> String
pandocToHTML [] = []
pandocToHTML (i:xs)
    | Str          s <- i = (check . entityToChar $ s) ++ pandocToHTML xs
    | Emph        is <- i = "<i>" ++ pandocToHTML is ++ "</i>" ++ pandocToHTML xs
    | SmallCaps   is <- i = "<span style=\"font-variant:small-caps;\">" ++ pandocToHTML is ++ "</span>" ++ pandocToHTML xs
    | Strong      is <- i = "<b>" ++ pandocToHTML is ++ "</b>" ++ pandocToHTML xs
    | Superscript is <- i = "<sup>" ++ pandocToHTML is ++ "</sup>" ++ pandocToHTML xs
    | Subscript   is <- i = "<sub>" ++ pandocToHTML is ++ "</sub>" ++ pandocToHTML xs
    | Space          <- i = " " ++ pandocToHTML xs
    | Quoted    t is <- i = case t of
                              DoubleQuote -> "“" ++ pandocToHTML is ++ "”" ++ pandocToHTML xs
                              SingleQuote -> "‘" ++ pandocToHTML is ++ "’" ++ pandocToHTML xs
    | Link     is x  <- i = case snd x of
                              "emph"     -> "<span style=\"font-style:normal;\">" ++
                                            pandocToHTML is ++ "</span>" ++ pandocToHTML xs
                              "strong"   -> "<span style=\"font-weight:normal;\">" ++
                                            pandocToHTML is ++ "</span>" ++ pandocToHTML xs
                              "nodecor"  -> "<span style=\"font-variant:normal;\">" ++
                                            pandocToHTML is ++ "</span>" ++ pandocToHTML xs
                              "baseline" -> "<span style=\"baseline\">" ++
                                            pandocToHTML is ++ "</span>" ++ pandocToHTML xs
                              _          -> pandocToHTML is ++ pandocToHTML xs

    | otherwise           = []
    where
      check ('&':[]) = "&#38;"
      check ('<':ys) = "&#60;" ++ check ys
      check ('>':ys) = "&#62;" ++ check ys
      check (y  :ys) = y : check ys
      check []       = []

unlines' :: [String] -> String
unlines'    []     = []
unlines' (x:[])    = x
unlines' (x:xs)    = x ++ "\n" ++ unlines' xs

#ifndef EMBED_DATA_FILES
localeCache :: IORef [(String, Locale)]
localeCache = System.IO.Unsafe.unsafePerformIO $ newIORef []

getCachedLocale :: String -> IO [Locale]
getCachedLocale n = maybe [] return `fmap` lookup n `fmap` readIORef localeCache

putCachedLocale :: String -> Locale -> IO ()
putCachedLocale n t = modifyIORef localeCache $ \l -> (n, t) : l
#endif

runTest :: Test -> IO (Bool,String)
runTest t = do
  let locale = case styleDefaultLocale $ testCSL t of
                 x | length x == 2 -> maybe "en-US"
                                      id (lookup x langBase)
                   | otherwise     -> take 5 x
#ifdef EMBED_DATA_FILES
  ls <- case lookup ("locales-" ++ locale ++ ".xml") localeFiles of
          Just x' -> return $ readXmlString xpLocale $ L.fromChunks [x']
          _       -> return $ Locale [] [] [] [] []
#else
  ls' <- getCachedLocale locale
  ls  <- case ls' of
           [] -> do l <- getDataFileName ("locales/locales-" ++ locale ++ ".xml")
                    b <- doesFileExist l
                    r <- if b
                         then readXmlFile xpLocale l
                         else readLocaleFile $ take 2 locale
                    putCachedLocale locale r
                    return r
           [x] -> return x
           _   -> return $ Locale [] [] [] [] []
#endif
  let opts   = procOpts { bibOpts = testBibSect t}
      style' = testCSL t
      style  = style' {styleLocale = mergeLocales (styleDefaultLocale style') ls $ styleLocale style'
                      ,styleAbbrevs = testAbbrevs t}
      cites  = case (testCitations t, testCitItems t) of
                 (Just cs, _      ) -> cs
                 (_,       Just cs) -> cs
                 _                  -> [map (\r -> emptyCite { citeId = refId r }) $ testInput t]
      (BD cits bib) = citeproc opts style (testInput t) cites
      output = superscript $
               case testMode t of
                 "citation" -> unlines'  . map (pandocToHTML . renderPandoc_ style) $ cits
                 _          -> pandocBib . map (pandocToHTML . renderPandoc_ style) $ bib
  return (output == getResult t, output)

test :: FilePath -> IO Bool
test = doTest readJsonFile 0

test' :: Int -> FilePath -> IO Bool
test' = doTest readJsonFile

test_ :: Int -> FilePath -> IO Bool
test_ = doTest readTestFile

doTest :: (FilePath -> IO JSValue) -> Int -> FilePath -> IO Bool
doTest rf v f = do
  when (v >= 2) $ putStrLn f
  t <- toTest `fmap` rf f
  (r,o) <- runTest t
  if r then return ()
       else do let putStrLn' = when (v >= 1) . putStrLn
               putStrLn  $ (tail .  takeWhile (/= '.') . dropWhile (/= '_')) f ++ " failed!"
               putStrLn' "++++++++++++++++++++++++++++++++++++++++++++++++++++++++"
               putStrLn' $ f ++ " failed!"
               putStrLn' "Expected:"
               putStrLn' $ getResult t
               putStrLn' "\nGot:"
               putStrLn' $ o
               when (v >= 3) $ putStrLn (show t)
               putStrLn' "++++++++++++++++++++++++++++++++++++++++++++++++++++++++"
  return r

runTS :: [String] -> Int -> FilePath -> IO ()
runTS gs v f = do
  st <- getCurrentTime
  putStrLn $ (++) (formatTime defaultTimeLocale "%H:%M:%S" st) $ " <--------------START"
  dc  <- sort `fmap` filter (isInfixOf ".json") `fmap` getDirectoryContents f
  let groupTests = map (head . map fst &&& map snd) .
                   groupBy (\x y -> fst x == fst y) .
                   map (takeWhile (/= '_') &&& tail . dropWhile (/= '_'))
      runGroups g = do putStrLn   "------------------------------------------------------------"
                       putStrLn $ "GROUP \"" ++ fst g ++ "\" has " ++ show (length $ snd g) ++ " tests to run"
                       putStrLn   "------------------------------------------------------------"
                       r' <- mapM (test' v . (++) (f ++ fst g ++ "_")) $ snd g
                       return r'
      filterGroup = if gs /= [] then filter (flip elem gs . fst) else id
  r <- mapM runGroups $ filterGroup $ groupTests dc
  putStrLn " ------------------------------------------------------------"
  putStrLn "| TEST SUMMARY:"
  putStrLn "------------------------------------------------------------"
  putStrLn $ "\t" ++ (show $ sum $ map length r) ++ " tests in " ++ (show $ length r) ++ " groups"
  putStrLn $ "\t" ++ (show $ sum $ map (length . filter id ) r) ++ " successes"
  putStrLn $ "\t" ++ (show $ sum $ map (length . filter not) r) ++ " failures"
  et <- getCurrentTime
  putStrLn $ (++) (formatTime defaultTimeLocale "%H:%M:%S" et) $ " <--------------END"
  putStrLn $ "Time: " ++ show (diffUTCTime et st)

getResult :: Test -> String
getResult t
    = if isJust (testCitations t) && testMode t == "citation"
      then unlines' . map  (\(a,b) -> drop (length (show b) + 5) a) .
           flip zip ([0..] :: [Int]) . lines . testResult $ t
      else testResult t

superscript :: String -> String
superscript [] = []
superscript (x:xs)
    = let a = lookup x (map (first (chr . readNum)) sups) in
      case a of
        Nothing -> x : superscript xs
        Just x' -> "<sup>" ++ [chr $ readNum x'] ++ "</sup>" ++ superscript xs
    where
      sups = [("0x00AA","0x0061"),("0x00B2","0x0032"),("0x00B3","0x0033"),("0x00B9","0x0031")
             ,("0x00BA","0x006F"),("0x02B0","0x0068"),("0x02B1","0x0266"),("0x02B2","0x006A")
             ,("0x02B3","0x0072"),("0x02B4","0x0279"),("0x02B5","0x027B"),("0x02B6","0x0281")
             ,("0x02B7","0x0077"),("0x02B8","0x0079"),("0x02E0","0x0263"),("0x02E1","0x006C")
             ,("0x02E2","0x0073"),("0x02E3","0x0078"),("0x02E4","0x0295"),("0x1D2C","0x0041")
             ,("0x1D2D","0x00C6"),("0x1D2E","0x0042"),("0x1D30","0x0044"),("0x1D31","0x0045")
             ,("0x1D32","0x018E"),("0x1D33","0x0047"),("0x1D34","0x0048"),("0x1D35","0x0049")
             ,("0x1D36","0x004A"),("0x1D37","0x004B"),("0x1D38","0x004C"),("0x1D39","0x004D")
             ,("0x1D3A","0x004E"),("0x1D3C","0x004F"),("0x1D3D","0x0222"),("0x1D3E","0x0050")
             ,("0x1D3F","0x0052"),("0x1D40","0x0054"),("0x1D41","0x0055"),("0x1D42","0x0057")
             ,("0x1D43","0x0061"),("0x1D44","0x0250"),("0x1D45","0x0251"),("0x1D46","0x1D02")
             ,("0x1D47","0x0062"),("0x1D48","0x0064"),("0x1D49","0x0065"),("0x1D4A","0x0259")
             ,("0x1D4B","0x025B"),("0x1D4C","0x025C"),("0x1D4D","0x0067"),("0x1D4F","0x006B")
             ,("0x1D50","0x006D"),("0x1D51","0x014B"),("0x1D52","0x006F"),("0x1D53","0x0254")
             ,("0x1D54","0x1D16"),("0x1D55","0x1D17"),("0x1D56","0x0070"),("0x1D57","0x0074")
             ,("0x1D58","0x0075"),("0x1D59","0x1D1D"),("0x1D5A","0x026F"),("0x1D5B","0x0076")
             ,("0x1D5C","0x1D25"),("0x1D5D","0x03B2"),("0x1D5E","0x03B3"),("0x1D5F","0x03B4")
             ,("0x1D60","0x03C6"),("0x1D61","0x03C7"),("0x2070","0x0030"),("0x2071","0x0069")
             ,("0x2074","0x0034"),("0x2075","0x0035"),("0x2076","0x0036"),("0x2077","0x0037")
             ,("0x2078","0x0038"),("0x2079","0x0039"),("0x207A","0x002B"),("0x207B","0x2212")
             ,("0x207C","0x003D"),("0x207D","0x0028"),("0x207E","0x0029"),("0x207F","0x006E")
             ,("0x3194","0x4E09"),("0x3195","0x56DB"),("0x3196","0x4E0A"),("0x3197","0x4E2D")
             ,("0x3198","0x4E0B"),("0x3199","0x7532"),("0x319A","0x4E59"),("0x319B","0x4E19")
             ,("0x319C","0x4E01"),("0x319D","0x5929"),("0x319E","0x5730"),("0x319F","0x4EBA")
             ,("0x02C0","0x0294"),("0x02C1","0x0295"),("0x06E5","0x0648"),("0x06E6","0x064A")]