    {-# 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")]