{-# LANGUAGE DeriveGeneric, StandaloneDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main (main) where

import Control.Applicative ((<|>))
import Control.Exception (IOException, catch)
import Control.Monad (when)
import Data.Foldable (traverse_)
import Data.List (foldl')
import Data.Traversable (for)
import GHC.Generics (Generic)
import Prelude
import System.Directory (getDirectoryContents)
import System.Exit (exitFailure)
import System.FilePath
import System.IO

import Data.TreeDiff
import Data.TreeDiff.Golden

import qualified Options.Applicative as O

import           Documentation.Haddock.Types
import qualified Documentation.Haddock.Parser as Parse

type Doc id = DocH () id

data Fixture = Fixture
    { fixtureName   :: FilePath
    , fixtureOutput :: FilePath
    }
  deriving Show

data  Result = Result
    { _resultSuccess :: !Int
    , _resultTotal   :: !Int
    }
  deriving Show

combineResults :: Result -> Result -> Result
combineResults (Result s t) (Result s' t') = Result (s + s') (t + t')

readFixtures :: IO [Fixture]
readFixtures = do
    let dir = "fixtures/examples"
    files <- getDirectoryContents dir
    let inputs = filter (\fp -> takeExtension fp == ".input") files
    return $ flip map inputs $ \fp -> Fixture
        { fixtureName = dir </> fp
        , fixtureOutput = dir </> fp -<.> "parsed"
        }

goldenFixture
    :: String
    -> IO Expr
    -> IO Expr
    -> (Expr -> Expr -> IO (Maybe String))
    -> (Expr -> IO ())
    -> IO Result
goldenFixture name expect actual cmp wrt = do
    putStrLn $ "running " ++ name
    a <- actual
    e <- expect `catch` handler a
    mres <- cmp e a
    case mres of
        Nothing  -> return (Result 1 1)
        Just str -> do
            putStrLn str
            return (Result 0 1)
  where
    handler :: Expr -> IOException -> IO Expr
    handler a exc = do
        putStrLn $ "Caught " ++ show exc
        putStrLn "Accepting the test"
        wrt a
        return a

runFixtures :: [Fixture] -> IO ()
runFixtures fixtures = do
    results <- for fixtures $ \(Fixture i o) -> do
        let name = takeBaseName i
        let readDoc = do
                input <- readFile i
                return (parseString input)
        ediffGolden goldenFixture name o readDoc
    case foldl' combineResults (Result 0 0) results of
        Result s t -> do
            putStrLn $ "Fixtures: success " ++ show s ++ "; total " ++ show t
            when (s /= t) exitFailure

listFixtures :: [Fixture] -> IO ()
listFixtures = traverse_ $ \(Fixture i _) -> do
    let name = takeBaseName i
    putStrLn name

acceptFixtures :: [Fixture] -> IO ()
acceptFixtures = traverse_ $ \(Fixture i o) -> do
    input <- readFile i
    let doc = parseString input
    let actual = show (prettyExpr $ toExpr doc) ++ "\n"
    writeFile o actual

parseString :: String -> Doc String
parseString = Parse.toRegular . _doc . Parse.parseParas Nothing

data Cmd = CmdRun | CmdAccept | CmdList

main :: IO ()
main = do
    hSetBuffering stdout NoBuffering -- For interleaved output when debugging
    runCmd =<< O.execParser opts
  where
    opts = O.info (O.helper <*> cmdParser) O.fullDesc

    cmdParser :: O.Parser Cmd
    cmdParser = cmdRun <|> cmdAccept <|> cmdList <|> pure CmdRun

    cmdRun = O.flag' CmdRun $ mconcat
        [ O.long "run"
        , O.help "Run parser fixtures"
        ]

    cmdAccept = O.flag' CmdAccept $ mconcat
        [ O.long "accept"
        , O.help "Run & accept parser fixtures"
        ]

    cmdList = O.flag' CmdList $ mconcat
        [ O.long "list"
        , O.help "List fixtures"
        ]

runCmd :: Cmd -> IO ()
runCmd CmdRun    = readFixtures >>= runFixtures
runCmd CmdList   = readFixtures >>= listFixtures
runCmd CmdAccept = readFixtures >>= acceptFixtures

-------------------------------------------------------------------------------
-- Orphans
-------------------------------------------------------------------------------

deriving instance Generic (DocH mod id)
instance (ToExpr mod, ToExpr id)  => ToExpr (DocH mod id)

deriving instance Generic (Header id)
instance ToExpr id => ToExpr (Header id)

deriving instance Generic (Hyperlink id)
instance ToExpr id => ToExpr (Hyperlink id)

deriving instance Generic (ModLink id)
instance ToExpr id => ToExpr (ModLink id)

deriving instance Generic Picture
instance ToExpr Picture

deriving instance Generic Example
instance ToExpr Example

deriving instance Generic (Table id)
instance ToExpr id => ToExpr (Table id)

deriving instance Generic (TableRow id)
instance ToExpr id => ToExpr (TableRow id)

deriving instance Generic (TableCell id)
instance ToExpr id => ToExpr (TableCell id)