{-# OPTIONS_GHC -Wall            #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE MultiWayIf          #-}
{-# LANGUAGE TupleSections       #-}

{-|

  Module      : AutoBench.Internal.IO
  Description : AutoBench's internal IO.
  Copyright   : (c) 2018 Martin Handley
  License     : BSD-style
  Maintainer  : martin.handley@nottingham.ac.uk
  Stability   : Experimental
  Portability : GHC

  This module deals with all AutoBench's internal IO, including:

  * System saving to/loading from files;
  * Generating/compiling/executing benchmarking files;
  * Cleaning up temporary files created for/during benchmarking;

-}

{-
   ----------------------------------------------------------------------------
   <TO-DO>:
   ----------------------------------------------------------------------------
   - generateBenchmarks error handling?
   - It would be nice for the generating benchmarking file to be nicely
     formatted;
   - Add more validation to generateBenchmarkingReport;
   - Handle CTRL-C?
-}

module AutoBench.Internal.IO
  (

  -- * IO for benchmarking files
    generateBenchmarkingFile            -- Generate a benchmarking file to benchmark all the test programs in a given test suite
  , generateTestReport                  -- Generate a 'TestReport' that summarises the system's testing phase.
  , compileBenchmarkingFile             -- Compile benchmarking file using zero or more user-specified compiler flags.
  , deleteAllFiles                      -- Delete all files created by the system.
  , deleteBenchmarkingFiles             -- Delete all files created for/during the benchmarking phase.
  , deleteTemporarySystemFiles          -- Delete temporary system files created for/during the benchmarking phase.
  -- * Helper functions
  , anyKeyExit                          -- Press any key to exit.
  , discoverInputFiles                  -- Discover potential input files in the working directory.
  , execute                             -- Execute a file, capturing its output to STDOUT and printing it to the command line.
  , generateBenchmarkingFilename        -- Generate a valid filename for the benchmarking file from the filename of the user input file.
  , nestPutStr                          -- Output documents at a specific level of nesting using 'putStr'.
  , nestPutStrLn                        -- Output documents at a specific level of nesting using 'putStrLn'.
  , spacer                              -- Output @n@ line spaces to the command line.

  ) where

import           Control.Exception         (catch)
import           Control.Exception.Base    (throwIO)
import           Control.Monad             (unless, void)
import           Control.Monad.Catch       (throwM)
import           Criterion.IO              (readJSONReports)
import qualified Data.ByteString           as BS
import qualified Data.ByteString.Char8     as C
import           Data.List                 ( groupBy, isInfixOf, partition, sort
                                           , sortBy )
import qualified Data.Map                  as Map
import           Data.Ord                  (comparing)
import qualified Data.Vector               as V
import qualified DynFlags                  as GHC
import qualified GHC                       as GHC
import qualified GHC.Paths                 as GHC
import           Statistics.Types          (estPoint)
import           System.Directory          ( doesFileExist, getDirectoryContents
                                           , removeFile )
import           System.FilePath.Posix     ( dropExtension, takeBaseName
                                           , takeDirectory, takeExtension )
import           System.IO                 (Handle, hFlush, stdout)
import           System.IO.Error           (isDoesNotExistError)
import qualified Text.PrettyPrint.HughesPJ as PP
import qualified Text.Megaparsec           as MP

import System.Process
  ( ProcessHandle
  , StdStream(..)
  , createProcess
  , getProcessExitCode
  , proc
  , std_out
  )

import Criterion.Types
 ( Report
 , anMean
 , anOutlierVar
 , anRegress
 , anStdDev
 , ovEffect
 , ovFraction
 , regCoeffs
 , regResponder
 , reportAnalysis
 , reportName
 , reportMeasured
 )

import AutoBench.Internal.AbstractSyntax (Id, ModuleName, prettyPrint, qualIdt)
import AutoBench.Internal.UserIO         (printGoodbyeMessage)
import AutoBench.Internal.Utils          (Parser, allEq, integer, symbol)
import AutoBench.Internal.Types
  ( BenchReport(..)
  , DataOpts(..)
  , DataSize(..)
  , InputError(..)
  , SimpleReport(..)
  , SystemError(..)
  , TestReport(..)
  , TestSuite(..)
  , UserInputs(..)
  )

-- * IO for benchmarking files:

-- | Generate a benchmarking file to benchmark all the test programs in a
-- given test suite. This includes generating/supplying necessary test data.
--
-- Note that the names of test programs and sizes of test inputs are encoded
-- into each benchmark's (i.e., test case's) title to keep track of
-- measurements. This allows for simple but necessary validation checks to be
-- performed on the JSON report file created by Criterion to ensure that test
-- results agree with test inputs. (The checks are done by
-- 'generateBenchmarkingReport'.)
generateBenchmarkingFile
  :: FilePath       -- ^ Filepath to save benchmarking file.
  -> ModuleName     -- ^ User input file's module name.
  -> UserInputs     -- ^ Parsed/categorised user inputs (to cross-reference).
  -> Id             -- ^ The chosen test suite's identifier.
  -> TestSuite      -- ^ The chosen test suite.
  -> IO ()
generateBenchmarkingFile fp mn inps tsIdt ts = do
  -- Generate functional call that will in turn generate the appropriate
  -- benchmarks.
  gFunc <- genFunc gen nf unary
  -- Generate file contents and write to file.
  writeFile fp (PP.render $ contents gFunc)

  where
    ---------------------------------------------------------------------------
    -- ** CHANGING THE CONTENTS WILL BREAK THE SYSTEM **
    ---------------------------------------------------------------------------
    -- Note: imports/definitions are qualified to avoid ambiguity.

    contents gFunc = PP.vcat
      [ PP.text ""
      , PP.text "module Main (main) where"
      , PP.text ""
      , PP.text "import qualified AutoBench.Internal.Benchmarking"       -- Import all generation functions.
      , PP.text "import qualified" PP.<+> PP.text mn                     -- Import user input file.
      , PP.text ""
      , PP.text "main :: IO ()"                                          -- Generate a main function.
      , PP.text "main  = AutoBench.Internal.Benchmarking.runBenchmarks"  -- Run benchmarks.
          PP.<+> PP.char '(' PP.<> gFunc PP.<> PP.char ')'               -- Generate benchmarks.
          PP.<+> PP.text (prettyPrint . qualIdt mn $ tsIdt)              -- Identifier of chosen test suite (for run cfg).
      ]

    ---------------------------------------------------------------------------
    -- ** CHANGING THE NAMES OF THESE FUNCTIONS WILL BREAK THE SYSTEM **
    ---------------------------------------------------------------------------
    -- Important note: each function below encodes the name of test programs
    -- and input sizes into the titles of benchmark test cases.
    ---------------------------------------------------------------------------

    -- Generate benchmarking function call.
    -- genFunc gen? nf? unary?
    genFunc :: Bool -> Bool -> Bool -> IO PP.Doc
    -- genBenchmarksGenNfUn:
    -- Generated test data, results to nf, unary test programs.
    genFunc True True True = return
      (genGenFunc "AutoBench.Internal.Benchmarking.genBenchmarksGenNfUn")
    -- genBenchmarksGenWhnfUn:
    -- Generated test data, results to whnf, unary test programs.
    genFunc True False True = return
      (genGenFunc "AutoBench.Internal.Benchmarking.genBenchmarksGenWhnfUn")
     -- genBenchmarksGenNfBin:
     -- Generated test data, results to nf, binary test programs.
    genFunc True  True  False = return
      (genGenFunc "AutoBench.Internal.Benchmarking.genBenchmarksGenNfBin")
    -- genBenchmarksGenWhnfBin:
    -- Generated test data, results to whnf, binary test programs.
    genFunc True  False False = return
      (genGenFunc "AutoBench.Internal.Benchmarking.genBenchmarksGenWhnfBin")
    -- genBenchmarksManNfUn:
    -- User-specified test data, results to nf, unary test programs.
    genFunc False True True =
      genManFunc "AutoBench.Internal.Benchmarking.genBenchmarksManNfUn"
    -- genBenchmarksManWhnfUn:
    -- User-specified test data, results to whnf, unary test programs.
    genFunc False False True =
      genManFunc "AutoBench.Internal.Benchmarking.genBenchmarksManWhnfUn"
    -- genBenchmarksManNfBin:
    -- User-specified test data, results to nf, binary test programs.
    genFunc False True False =
       genManFunc "AutoBench.Internal.Benchmarking.genBenchmarksManNfBin"
    -- genBenchmarksManWhnfBin:
    -- User-specified test data, results to whnf, binary test programs.
    genFunc False False False =
       genManFunc "AutoBench.Internal.Benchmarking.genBenchmarksManWhnfBin"

    -- Generate function call for benchmarks requiring automatically generated
    -- test data.
    genGenFunc :: Id -> PP.Doc
    genGenFunc func = PP.hsep $
        [ PP.text func
        , ppList $ fmap ppTuple qualProgs
        , PP.text (prettyPrint . qualIdt mn $ tsIdt)
        ]

    -- Generate function call for benchmarks using user-specified test data.
    genManFunc :: Id -> IO PP.Doc
    genManFunc func = do
      dat <- getManualDatIdt (_dataOpts ts)
      return $ PP.hsep
        [ PP.text func
        , ppList $ fmap ppTuple qualProgs
        , PP.text (prettyPrint . qualIdt mn $ tsIdt)
        , PP.text (prettyPrint . qualIdt mn $ dat)
        ]

    -- Pretty print an (identifier, program) tuple.
    ppTuple :: Id -> PP.Doc
    ppTuple idt = PP.char '('
      PP.<> PP.text (show idt)
      PP.<> PP.text ", "
      PP.<> PP.text idt
      PP.<> PP.char ')'

    -- Pretty print a comma-separated list.
    ppList :: [PP.Doc] -> PP.Doc
    ppList docs = PP.hcat $
      PP.char '[' : (PP.punctuate (PP.text ", ") docs) ++ [PP.char ']']

    -- Helpers

    -- Classifiers:
    unary = head (_progs ts) `elem` fmap fst (_unaryFuns inps)  -- Unary test programs?
    nf    = _nf ts                                              -- NF test results?
    gen   = case _dataOpts ts of                                -- Generate test data?
      Manual{} -> False
      Gen{}    -> True

    -- All test programs are qualified with the module name.
    qualProgs = fmap (prettyPrint . qualIdt mn) (_progs ts)

    -- Get the identifier of User-specified test data from 'DataOpts'.
    -- Questionable throwM error handling here? But better than a partial function.
    getManualDatIdt :: DataOpts -> IO Id
    getManualDatIdt (Manual s) = return s
    getManualDatIdt Gen{} =
      throwM (InternalErr $ "generateBenchmarks: unexpected 'Gen' setting.")

-- | Use GHC to compile the benchmarking file. Compile using the flags
-- specified in the 'TestSuite' used to generate the benchmarking file.
-- Includes the location of the user input file as a source directory in case
-- it is not the working directory. Any invalid compiler flags are returned
-- in case they affect test results.
compileBenchmarkingFile
  :: FilePath     -- ^ Benchmarking filepath.
  -> FilePath     -- ^ User input filepath.
  -> [String]     -- ^ GHC compiler flags.
  -> IO [String]  -- ^ Invalid compiler flags.
compileBenchmarkingFile benchFP userFP flags = do
  (success, invalidFlags) <- GHC.runGhc (Just GHC.libdir) $ do
    dflags <- GHC.getSessionDynFlags
    -- Add flags specified in 'TestSuite's '_ghcFlags' list.
    (dflags', invalidFlags, _) <- GHC.parseDynamicFlagsCmdLine dflags (GHC.noLoc <$> flags)
    -- Include location of input file in import paths.
    let dflags'' = dflags' { GHC.importPaths = GHC.importPaths dflags ++ [takeDirectory userFP] }
    void $ GHC.setSessionDynFlags dflags''
    target <- GHC.guessTarget benchFP Nothing
    GHC.setTargets [target]
    success <- GHC.succeeded <$> GHC.load GHC.LoadAllTargets
    return (success, fmap GHC.unLoc invalidFlags)
  -- Throw an error if compilation fails.
  unless success (throwIO $ FileErr "Compilation failed.")
  -- Notify user of any invalid flags in case they affect test results.
  return invalidFlags

-- | Delete all files created for/during the benchmarking phase
-- of testing, including:
--
-- * Benchmarking Haskell module;
-- * Benchmarking binary;
-- * *.o, *.hi files;
-- * Temporary system files e.g., Criterion JSON report file.
deleteAllFiles :: FilePath -> FilePath -> [FilePath] -> IO ()
deleteAllFiles fBench fUser sysTmps =
  mapM_ removeIfExists (fUsers ++ fBenchs ++ sysTmps)
  where
    fUsers   = fmap (dropExtension fUser ++) exts
    fBench'  = dropExtension fBench
    fBenchs  = fBench : fBench' : fmap (fBench' ++ ) exts
    exts     = [".o", ".hi"]

    removeIfExists fp = removeFile fp `catch` handleExists
      where handleExists e | isDoesNotExistError e = return ()
                           | otherwise = throwIO e

-- | Delete files created for/during the benchmarking phase of testing,
-- including:
--
-- * Benchmarking Haskell module;
-- * Benchmarking binary;
-- * *.o, *.hi files;
deleteBenchmarkingFiles :: FilePath -> FilePath -> IO ()
deleteBenchmarkingFiles fBench fUser =
  mapM_ removeIfExists (fUsers ++ fBenchs)
  where
    fUsers   = fmap (dropExtension fUser ++) exts
    fBench'  = dropExtension fBench
    fBenchs  = fBench : fBench' : fmap (fBench' ++ ) exts
    exts     = [".o", ".hi"]

    removeIfExists fp = removeFile fp `catch` handleExists
      where handleExists e | isDoesNotExistError e = return ()
                           | otherwise = throwIO e

-- | Delete temporary files created for/during the benchmarking phase
-- of testing, e.g., Criterion JSON report file.
deleteTemporarySystemFiles :: [FilePath] -> IO ()
deleteTemporarySystemFiles systemTemps =
  mapM_ removeIfExists systemTemps
  where
    removeIfExists fp = removeFile fp `catch` handleExists
      where handleExists e | isDoesNotExistError e = return ()
                           | otherwise = throwIO e

-- | Generate a test report to summarise the system's testing phase. This
-- includes parsing the JSON benchmark report file created by Criterion
-- in order to generate a 'BenchReport': see 'generateBenchmarkingReport'.
generateTestReport
  :: ModuleName -- Module name of user input file.
  -> TestSuite  -- TestSuite used to generate benchmarking file.
  -> FilePath   -- Filepath of Criterion's JSON report.
  -> Bool       -- Whether test programs are semantically equal according to QuickCheck testing.
  -> IO TestReport
generateTestReport mn ts fp eql = do
  -- Generate benchmarking report.
  benchRep <- generateBenchmarkingReport mn ts fp
  return TestReport
           { -- Copy 'TestSuite' settings:
             _tProgs    = sort $ fmap (prettyPrint . qualIdt mn) (_progs ts)
           , _tDataOpts = _dataOpts ts
           , _tNf       = _nf ts
           , _tGhcFlags = _ghcFlags ts
             -- Other test results:
           , _eql       = eql
           , _br        = benchRep
           }

-- | Parse a Criterion JSON report file and use the parsed '[Report]'s to
-- generate a 'BenchReport' that summarises the benchmarking phase of testing.
-- The 'BenchReport' includes a 'SimpleReport' for each test case and baseline
-- measurements, if applicable.
--
-- Some background information:
-- When generating the benchmarking file using 'generateBenchmarkingFile',
-- the names of test programs and input sizes are encoded into the titles of
-- benchmarks. The 'Report' titles are decoded here and checked against the
-- settings of the 'TestSuite used to generate the benchmarks initially.
generateBenchmarkingReport                                                                          -- <TO-DO>: Check input size against the 'UserInputs' data structure.
  :: ModuleName -- Module name of user input file.
  -> TestSuite  -- TestSuite used to generate benchmarking file.                                    -- <TO-DO>: Are these checks sufficient?
  -> FilePath   -- Filepath of Criterion's JSON report.
  -> IO BenchReport
generateBenchmarkingReport mn ts fp = do
  -- Check file exists.
  exists <- doesFileExist fp
  unless exists (throwIO $ FileErr $ "Cannot locate Criterion report: " ++ fp)
  -- Generate 'BenchReport' largely from Criterion's JSON results.
  -- Parse Criterion JSON report.
  readJSONReports fp >>= \case
    -- Parse error.
    Left err -> throwIO (FileErr $ "Invalid Criterion report: " ++ err)
    -- Parsed 'ReportFileContents', only care about 'Report's.
    Right (_, _, reps) ->
      -- Reports are organised differently depending on whether baseline
      -- measurements were taken so separate the baseline measurements.
      let (bls, nonBls) = partition (("Baseline for" `isInfixOf`) . reportName) reps
      in case bls of
        -- If there isn't any baseline measurements, all reports are
        -- test program measurements and have titles such as
        -- Input Size 5/p1    Input Size 5/p2     Input Size 5/p3    for unary.
        -- Input Sizes (5, 5)/p1     Input Sizes (5, 5)/p2           for binary.
        [] -> case noBaselines reps of -- Use 'parseRepName' to parse titles to
                                       -- (Id, DataSize) tuples.
          Nothing -> throwIO $ FileErr $ "Incompatible Criterion report."
          Just xs -> return $ convertReps [] (zip reps xs)
        -- If baseline measurements have been taken, then reports relating
        -- to test program measurements have titles such as:
        -- With Baseline/Input Size 5/p1 etc.
        -- And baseline measurements have titles such as:
        -- With Baseline/Baseline Measurement for Input Size 5.
        _  -> case withBaselines bls nonBls of
           -- Use 'parseRepName' to parse titles to (Id, DataSize) tuples
           -- and 'parseBaseline' to parse baseline measurements to same format.
          Nothing -> throwIO $ FileErr $ "Incompatible Criterion report."
          Just (nBls, nNonBls) ->
            return $ convertReps (zip bls nBls) (zip nonBls nNonBls)

    where
      -- Qualified '_progs' list
      progs = sort $ fmap (prettyPrint . qualIdt mn) (_progs ts)

      -- The overall idea is that the titles of the Criterion reports encode
      -- the names of test programs and the sizes of test inputs. The titles
      -- are decoded and the parsed data is checked against the settings of the
      -- 'TestSuite' used to generate the benchmarks in the first place. This is
      -- perhaps a little over cautious but I think it's worth it.

      -- Parse the report titles of the baseline and test program measurements.
      withBaselines
        :: [Report] -- Baseline measurements.
        -> [Report] -- Test program measurements.
        -> Maybe ([(Id, DataSize)], [(Id, DataSize)])
      withBaselines _ [] = Nothing
      withBaselines bls nonBls = do

        -- Parse titles of baseline measurements. dropWhile (/= 'I') "With
        -- Baseline/Baseline Measurement for Input Size 5" ===> "Input Size 5",
        -- then can use 'parseBaseline'.
        nBls <- sequence $ fmap (MP.parseMaybe parseBaseline .
          dropWhile (/= 'I') . reportName) bls

        -- Parse titles of test program measurements.
        -- dropWhile (/= 'I') "With Baseline/Input Size 5/p1" ===> "Input Size
        -- 5/p1", then can use 'parseRepName'.
        nNonBls <- sequence $ fmap (MP.parseMaybe parseRepName .
          dropWhile (/= 'I') . reportName) nonBls
        -- Group parse results relating to the same test program by grouping
        -- by identifier.

        let nNonBlss = groupBy (\x1 x2 -> fst x1 == fst x2) $
                         sortBy (comparing fst) nNonBls
        -- The size range of test data for each test program.
            sizes = fmap (sort . fmap snd) nNonBlss
        -- Validation checks:
        if | not (allEq $ sort (fmap snd nBls) : sizes) -> Nothing                        -- (1) Make sure same number of measurements for each program
                                                                                --     and all have same input sizes.
           | not $ (sort $ fmap (fst . head) nNonBlss) == progs -> Nothing                -- (2) Make sure test programs match those in the 'TestSuite's '_progs' list.
                                                                                -- (3) <TO-DO>: Some form of input size check against 'UserInputs' data structure.
           | otherwise -> Just (nBls, nNonBls)

      -- Parse the report titles of just the test program measurements.
      noBaselines :: [Report] -> Maybe [(Id, DataSize)]
      noBaselines [] = Nothing
      noBaselines reps = do
        -- Parse titles of test program measurements.
        xs <- sequence $ fmap (MP.parseMaybe parseRepName . reportName) reps
        -- Group parse results relating to the same test program.
        let xss = groupBy (\x1 x2 -> fst x1 == fst x2) $ sortBy (comparing fst) xs
        -- The size range of test data for each test program.
            sizes = fmap (sort . fmap snd) xss
        -- Validation checks:
        if | not (allEq sizes) -> Nothing                                                 -- (1) Make sure same number of measurements for each program
                                                                                --     and all have same input sizes.
           | not $ (sort $ fmap (fst . head) xss) == progs -> Nothing                     -- (2) Make sure test programs match those in the 'TestSuite's '_progs' list.
                                                                                -- (3) <TO-DO>: Some form of input size check against 'UserInputs' data structure.
           | otherwise -> Just xs

      -- Convert a set of Criterion 'Report's from the same test into a
      -- 'BenchReport' by generating a 'SimpleReport' for each test case
      -- and baseline measurement. Copy over some settings from the 'TestSuite'
      -- used to generate the benchmarks initially.
      convertReps
        :: [(Report, (Id, DataSize))] -- Baseline measurements.
        -> [(Report, (Id, DataSize))] -- Test program measurements.
        -> BenchReport
      convertReps bls nonBls =
        BenchReport
          { -- Generate test program 'SimpleReport's.
            _reports = fmap (fmap $ uncurry toSimpleReport) .
              -- Group by test program's identifier.
              groupBy (\(_, (idt1, _)) (_, (idt2, _)) -> idt1 == idt2) .
              -- Sort by test program's identifier.
              sortBy  (\(_, (idt1, _)) (_, (idt2, _)) -> compare idt1 idt2) $ nonBls
          -- Generate 'SimpleReport's for baseline measurements.
          , _baselines = fmap (uncurry toSimpleReport) $ sortBy (comparing snd) bls
          }

        where

         -- Convert a Criterion 'Report' to a 'SimpleReport' for a given
         -- (test program identifier, input size).
         toSimpleReport :: Report -> (Id, DataSize) -> SimpleReport
         toSimpleReport rep (idt, size) =
           SimpleReport
              { _name    = idt
              , _size    = size
              , _runtime = getRegressTime -- Use the runtime predicted by linear regression, /not mean/.
                                          -- ** But fall back on mean if something goes wrong **.
               -- Note: Criterion uses a large number of samples to calculate its statistics.
               -- Each sample itself is a number of iterations, but then the measurements are
               -- standardised, so length here should work(?)
              , _samples    = V.length (reportMeasured rep)
              , _stdDev     = estPoint   . anStdDev     . reportAnalysis $ rep
              , _outVarEff  = ovEffect   . anOutlierVar . reportAnalysis $ rep
              , _outVarFrac = ovFraction . anOutlierVar . reportAnalysis $ rep
              }
           where
             -- Lookup the runtime predicted by linear regression.
             getRegressTime = case filter (\reg -> regResponder reg == "time")
               (anRegress $ reportAnalysis rep) of
                 [x] -> case estPoint <$> Map.lookup "iters" (regCoeffs x) of
                          Just d -> d
                          -- Fall back on mean.
                          Nothing -> mean
                 -- Fall back on mean.
                 _ -> mean

               where mean = estPoint . anMean . reportAnalysis $ rep

      -- Parser helpers to decode report titles: ------------------------------

      -- Parse a report's title into the corresponding test
      -- program's identifier and input size.
      parseRepName :: Parser (Id, DataSize)
      parseRepName  = do
        -- E.g., "Input Sizes (5, 5)/p1"
        -- E.g., "Input Size 5/p2"
        void $ (symbol "Input Sizes") MP.<|> (symbol "Input Size")
        ds <- parseDataSize
        void $ symbol "/"
        idt <- MP.manyTill MP.anySingle MP.eof
        return (idt, ds)

      -- Parse the encoded baseline size from the name of a Criterion report.
      -- E.g., Input Sizes (5, 5) or Input Size 5
      parseBaseline :: Parser (Id, DataSize)
      parseBaseline = do
        void $ (symbol "Input Sizes") MP.<|> (symbol "Input Size")
        ("Baseline measurements",) <$> parseDataSize                                                -- <TO-DO>: This is too important to be a string.

      -- Parse the encoded data size from the name of a Criterion report.
      -- E.g., (5, 5) or 5.
      parseDataSize :: Parser DataSize
      parseDataSize  = (do
        void $ symbol "("
        n1 <- integer
        void $ symbol ","
        n2 <- integer
        void $ symbol ")"
        return (SizeBin n1 n2)) MP.<|> (SizeUn <$> integer)

-- * Helper functions

-- | Execute a file, capturing its output to STDOUT and printing it to the
-- command line.
execute :: FilePath -> IO ()
execute fp = do
  let p = (proc fp []) { std_out = CreatePipe }
  (_, Just out, _, ph) <- createProcess p
  printOutput ph out
  where
    printOutput :: ProcessHandle -> Handle -> IO ()
    printOutput ph h = go
      where
        go = do
          bs <- BS.hGetNonBlocking h (64 * 1024)
          printLine bs
          ec <- getProcessExitCode ph
          maybe go (const $ do
            end <- BS.hGetContents h
            printLine end) ec
        printLine bs = unless (BS.null bs) (C.putStr bs)

-- | Generate a valid filename for the benchmarking file from the filename of
-- the user input file.
generateBenchmarkingFilename :: String -> IO String
generateBenchmarkingFilename s = do
  b1 <- doesFileExist s'
  b2 <- doesFileExist (addSuffix s')
  if b1 || b2
    then go s' 0
    else return (addSuffix s')
  where
    go :: String -> Int -> IO String
    go s_ i = do
      let s_' = s_ ++ show i
      b1 <- doesFileExist s_'
      b2 <- doesFileExist (addSuffix s_')
      if b1 || b2
        then go s_ (i + 1)
        else return (addSuffix s_')

    addSuffix = (++ ".hs")
    s'        = takeDirectory s ++ "/Bench" ++ takeBaseName s

-- | Discover potential input files in the working directory.
discoverInputFiles :: IO [FilePath]
discoverInputFiles  = filter ((== ".hs") . takeExtension) <$> getDirectoryContents "."

-- | Press any key to exit.
anyKeyExit :: IO ()
anyKeyExit  = do
  putStr "Press any key to exit... "
  hFlush stdout
  -- Want to use Haskeline here but can't.
  -- https://github.com/judah/haskeline/issues/74
  void getChar
  printGoodbyeMessage

-- | Output @n@ line spaces to the command line.
spacer :: Int -> IO ()
spacer n = putStrLn (replicate (n - 1) '\n') >> hFlush stdout

-- | Output documents at a specific level of nesting using 'putStr'.
nestPutStr :: Int -> PP.Doc -> IO ()
nestPutStr n doc = putStr (PP.render $ PP.nest n doc) >> hFlush stdout

-- | Output documents at a specific level of nesting using 'putStrLn'.
nestPutStrLn :: Int -> PP.Doc -> IO ()
nestPutStrLn n doc = putStrLn (PP.render $ PP.nest n doc) >> hFlush stdout


{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes#-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE EmptyCase #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | Internal API for the store package. The functions here which are
-- not re-exported by "Data.Store" are less likely to have stable APIs.
--
-- This module also defines most of the included 'Store' instances, for
-- types from the base package and other commonly used packages
-- (bytestring, containers, text, time, etc).
module Data.Store.Internal
    (
    -- * Encoding and decoding strict ByteStrings.
      encode,
      decode, decodeWith,
      decodeEx, decodeExWith, decodeExPortionWith
    , decodeIO, decodeIOWith, decodeIOPortionWith
    -- * Store class and related types.
    , Store(..), Poke, Peek, runPeek
    -- ** Exceptions thrown by Poke
    , PokeException(..), pokeException
    -- ** Exceptions thrown by Peek
    , PeekException(..), peekException, tooManyBytes
    -- ** Size type
    , Size(..)
    , getSize, getSizeWith
    , combineSize, combineSizeWith, addSize
    -- ** Store instances in terms of IsSequence
    , sizeSequence, pokeSequence, peekSequence
    -- ** Store instances in terms of IsSet
    , sizeSet, pokeSet, peekSet
    -- ** Store instances in terms of IsMap
    , sizeMap, pokeMap, peekMap
    -- *** Utilities for ordered maps
    , sizeOrdMap, pokeOrdMap, peekOrdMapWith
    -- ** Store instances in terms of IArray
    , sizeArray, pokeArray, peekArray
    -- ** Store instances in terms of Generic
    , GStoreSize, genericSize
    , GStorePoke, genericPoke
    , GStorePeek, genericPeek
    -- ** Peek utilities
    , skip, isolate
    , peekMagic
    -- ** Static Size type
    --
    -- This portion of the library is still work-in-progress.
    -- 'IsStaticSize' is only supported for strict ByteStrings, in order
    -- to support the use case of 'Tagged'.
    , IsStaticSize(..), StaticSize(..), toStaticSizeEx, liftStaticSize, staticByteStringExp
    ) where

import           Control.Applicative
import           Control.DeepSeq (NFData)
import           Control.Exception (throwIO)
import           Control.Monad (when)
import           Control.Monad.IO.Class (liftIO)
import qualified Data.Array.Unboxed as A
import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Short.Internal as SBS
import           Data.Containers (IsMap, ContainerKey, MapValue, mapFromList, mapToList, IsSet, setFromList)
import           Data.Complex (Complex (..))
import           Data.Data (Data)
import           Data.Fixed (Fixed (..), Pico)
import           Data.Foldable (forM_, foldl')
import           Data.Functor.Contravariant
import           Data.Functor.Identity (Identity (..))
import           Data.HashMap.Strict (HashMap)
import           Data.HashSet (HashSet)
import           Data.Hashable (Hashable)
import           Data.Int
import           Data.IntMap (IntMap)
import qualified Data.IntMap.Strict as IntMap
import           Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
import qualified Data.List.NonEmpty as NE
import           Data.Map (Map)
import qualified Data.Map.Strict as Map
import           Data.MonoTraversable
import           Data.Monoid
import           Data.Orphans ()
import           Data.Primitive.ByteArray
import           Data.Proxy (Proxy(..))
import           Data.Sequence (Seq)
import           Data.Sequences (IsSequence, Index, replicateM)
import           Data.Set (Set)
import qualified Data.Set as Set
import           Data.Store.Impl
import           Data.Store.Core
import           Data.Store.TH.Internal
import qualified Data.Text as T
import qualified Data.Text.Array as TA
import qualified Data.Text.Foreign as T
import qualified Data.Text.Internal as T
import qualified Data.Time as Time
import qualified Data.Time.Clock.TAI as Time
import           Data.Typeable (Typeable)
import qualified Data.Vector as V
import qualified Data.Vector.Mutable as MV
import qualified Data.Vector.Storable as SV
import qualified Data.Vector.Storable.Mutable as MSV
import           Data.Void
import           Data.Word
import           Foreign.C.Types ()
import           Foreign.Ptr (plusPtr, minusPtr)
import           Foreign.Storable (Storable, sizeOf)
import           GHC.Generics (Generic)
import           GHC.Real (Ratio(..))
import           GHC.TypeLits
import           Instances.TH.Lift ()
import           Language.Haskell.TH
import           Language.Haskell.TH.Instances ()
import           Language.Haskell.TH.ReifyMany
import           Language.Haskell.TH.Syntax
import           Network.Socket (AddrInfo)
import           Numeric.Natural (Natural)
import           Prelude
import           TH.Derive

#if MIN_VERSION_time(1,8,0)
import qualified Data.Time.Clock.System as Time
#endif
#if MIN_VERSION_time(1,9,0)
import qualified Data.Time.Format.ISO8601 as Time
#endif
#if MIN_VERSION_time(1,11,0)
import qualified Data.Time.Calendar.Quarter as Time
import qualified Data.Time.Calendar.WeekDate as Time
#endif

#ifdef INTEGER_GMP
import qualified GHC.Integer.GMP.Internals as I
import           GHC.Types (Int (I#))
#else
import           GHC.Types (Word (W#))
import qualified GHC.Integer.Simple.Internals as I
#endif

-- Conditional import to avoid warning
#ifdef INTEGER_GMP
#if MIN_VERSION_integer_gmp(1,0,0)
import           GHC.Prim (sizeofByteArray#)
#endif
#endif

-- TODO: higher arities?  Limited now by Generics instances for tuples
$(return $ map deriveTupleStoreInstance [2..7])

$(deriveManyStoreFromStorable
  (\ty ->
    case ty of
      ConT n | elem n [''Char, ''Int, ''Int64, ''Word, ''Word8, ''Word32] -> True
      _ -> False
    ))

------------------------------------------------------------------------
-- Utilities for defining list-like 'Store' instances in terms of 'IsSequence'

-- | Implement 'size' for an 'IsSequence' of 'Store' instances.
--
-- Note that many monomorphic containers have more efficient
-- implementations (for example, via memcpy).
sizeSequence :: forall t. (IsSequence t, Store (Element t)) => Size t
sizeSequence = VarSize $ \t ->
    case size :: Size (Element t) of
        ConstSize n -> n * (olength t) + sizeOf (undefined :: Int)
        VarSize f -> ofoldl' (\acc x -> acc + f x) (sizeOf (undefined :: Int)) t
{-# INLINE sizeSequence #-}

-- | Implement 'poke' for an 'IsSequence' of 'Store' instances.
--
-- Note that many monomorphic containers have more efficient
-- implementations (for example, via memcpy).
pokeSequence :: (IsSequence t, Store (Element t)) => t -> Poke ()
pokeSequence t =
  do pokeStorable len
     Poke (\ptr offset ->
             do offset' <-
                  ofoldlM (\offset' a ->
                             do (offset'',_) <- runPoke (poke a) ptr offset'
                                return offset'')
                          offset
                          t
                return (offset',()))
  where len = olength t
{-# INLINE pokeSequence #-}

-- | Implement 'peek' for an 'IsSequence' of 'Store' instances.
--
-- Note that many monomorphic containers have more efficient
-- implementations (for example, via memcpy).
peekSequence :: (IsSequence t, Store (Element t), Index t ~ Int) => Peek t
peekSequence = do
    len <- peek
    replicateM len peek
{-# INLINE peekSequence #-}

------------------------------------------------------------------------
-- Utilities for defining list-like 'Store' instances in terms of 'IsSet'

-- | Implement 'size' for an 'IsSet' of 'Store' instances.
sizeSet :: forall t. (IsSet t, Store (Element t)) => Size t
sizeSet = VarSize $ \t ->
    case size :: Size (Element t) of
        ConstSize n -> n * (olength t) + sizeOf (undefined :: Int)
        VarSize f -> ofoldl' (\acc x -> acc + f x) (sizeOf (undefined :: Int)) t
{-# INLINE sizeSet #-}

-- | Implement 'poke' for an 'IsSequence' of 'Store' instances.
pokeSet :: (IsSet t, Store (Element t)) => t -> Poke ()
pokeSet t = do
    pokeStorable (olength t)
    omapM_ poke t
{-# INLINE pokeSet #-}

-- | Implement 'peek' for an 'IsSequence' of 'Store' instances.
peekSet :: (IsSet t, Store (Element t)) => Peek t
peekSet = do
    len <- peek
    setFromList <$> replicateM len peek
{-# INLINE peekSet #-}

------------------------------------------------------------------------
-- Utilities for defining list-like 'Store' instances in terms of a 'IsMap'

-- | Implement 'size' for an 'IsMap' of where both 'ContainerKey' and
-- 'MapValue' are 'Store' instances.
sizeMap
    :: forall t. (Store (ContainerKey t), Store (MapValue t), IsMap t)
    => Size t
sizeMap = VarSize $ \t ->
    case (size :: Size (ContainerKey t), size :: Size (MapValue t)) of
        (ConstSize nk, ConstSize na) -> (nk + na) * olength t + sizeOf (undefined :: Int)
        (szk, sza) -> ofoldl' (\acc (k, a) -> acc + getSizeWith szk k + getSizeWith sza a)
                              (sizeOf (undefined :: Int))
                              (mapToList t)
{-# INLINE sizeMap #-}

-- | Implement 'poke' for an 'IsMap' of where both 'ContainerKey' and
-- 'MapValue' are 'Store' instances.
pokeMap
    :: (Store (ContainerKey t), Store (MapValue t), IsMap t)
    => t
    -> Poke ()
pokeMap = pokeSequence . mapToList
{-# INLINE pokeMap #-}

-- | Implement 'peek' for an 'IsMap' of where both 'ContainerKey' and
-- 'MapValue' are 'Store' instances.
peekMap
    :: (Store (ContainerKey t), Store (MapValue t), IsMap t)
    => Peek t
peekMap = mapFromList <$> peek
{-# INLINE peekMap #-}

------------------------------------------------------------------------
-- Utilities for defining 'Store' instances for ordered containers like
-- 'IntMap' and 'Map'

-- | Marker for maps that are encoded in ascending order instead of the
-- descending order mistakenly implemented in 'peekMap' in store versions
-- < 0.4.
--
-- See https://github.com/fpco/store/issues/97.
markMapPokedInAscendingOrder :: Word32
markMapPokedInAscendingOrder = 1217678090

-- | Ensure the presence of a given magic value.
--
-- Throws a 'PeekException' if the value isn't present.
peekMagic
    :: (Eq a, Show a, Store a)
    => String -> a -> Peek ()
peekMagic markedThing x = do
    x' <- peek
    when (x' /= x) $
        fail ("Expected marker for " ++ markedThing ++ ": " ++ show x ++ " but got: " ++ show x')
{-# INLINE peekMagic #-}

-- | Like 'sizeMap' but should only be used for ordered containers where
-- 'Data.Containers.mapToList' returns an ascending list.
sizeOrdMap
    :: forall t.
       (Store (ContainerKey t), Store (MapValue t), IsMap t)
    => Size t
sizeOrdMap =
    combineSizeWith (const markMapPokedInAscendingOrder) id size sizeMap
{-# INLINE sizeOrdMap #-}

-- | Like 'pokeMap' but should only be used for ordered containers where
-- 'Data.Containers.mapToList' returns an ascending list.
pokeOrdMap
    :: (Store (ContainerKey t), Store (MapValue t), IsMap t)
    => t -> Poke ()
pokeOrdMap x = poke markMapPokedInAscendingOrder >> pokeMap x
{-# INLINE pokeOrdMap #-}

-- | Decode the results of 'pokeOrdMap' using a given function to construct
-- the map.
peekOrdMapWith
    :: (Store (ContainerKey t), Store (MapValue t))
    => ([(ContainerKey t, MapValue t)] -> t)
       -- ^ A function to construct the map from an ascending list such as
       -- 'Map.fromDistinctAscList'.
    -> Peek t
peekOrdMapWith f = do
    peekMagic "ascending Map / IntMap" markMapPokedInAscendingOrder
    f <$> peek
{-# INLINE peekOrdMapWith #-}

------------------------------------------------------------------------
-- Utilities for implementing 'Store' instances for list-like mutable things

-- | Implementation of peek for mutable sequences. The user provides a
-- function for initializing the sequence and a function for mutating an
-- element at a particular index.
peekMutableSequence
    :: Store a
    => (Int -> IO r)
    -> (r -> Int -> a -> IO ())
    -> Peek r
peekMutableSequence new write = do
    n <- peek
    mut <- liftIO (new n)
    forM_ [0..n-1] $ \i -> peek >>= liftIO . write mut i
    return mut
{-# INLINE peekMutableSequence #-}

------------------------------------------------------------------------
-- Useful combinators

-- | Skip n bytes forward.
{-# INLINE skip #-}
skip :: Int -> Peek ()
skip len = Peek $ \ps ptr -> do
    let ptr2 = ptr `plusPtr` len
        remaining = peekStateEndPtr ps `minusPtr` ptr
    when (len > remaining) $ -- Do not perform the check on the new pointer, since it could have overflowed
        tooManyBytes len remaining "skip"
    return $ PeekResult ptr2 ()

-- | Isolate the input to n bytes, skipping n bytes forward. Fails if @m@
-- advances the offset beyond the isolated region.
{-# INLINE isolate #-}
isolate :: Int -> Peek a -> Peek a
isolate len m = Peek $ \ps ptr -> do
    let end = peekStateEndPtr ps
        ptr2 = ptr `plusPtr` len
        remaining = end `minusPtr` ptr
    when (len > remaining) $ -- Do not perform the check on the new pointer, since it could have overflowed
        tooManyBytes len remaining "isolate"
    PeekResult ptr' x <- runPeek m ps ptr
    when (ptr' > end) $
        throwIO $ PeekException (ptr' `minusPtr` end) "Overshot end of isolated bytes"
    return $ PeekResult ptr2 x

------------------------------------------------------------------------
-- Instances for types based on flat representations

instance Store a => Store (V.Vector a) where
    size = sizeSequence
    poke = pokeSequence
    peek = V.unsafeFreeze =<< peekMutableSequence MV.new MV.write

instance Storable a => Store (SV.Vector a) where
    size = VarSize $ \x ->
        sizeOf (undefined :: Int) +
        sizeOf (undefined :: a) * SV.length x
    poke x = do
        let (fptr, len) = SV.unsafeToForeignPtr0 x
        poke len
        pokeFromForeignPtr fptr 0 (sizeOf (undefined :: a) * len)
    peek = do
        len <- peek
        fp <- peekToPlainForeignPtr "Data.Storable.Vector.Vector" (sizeOf (undefined :: a) * len)
        liftIO $ SV.unsafeFreeze (MSV.MVector len fp)

instance Store BS.ByteString where
    size = VarSize $ \x ->
        sizeOf (undefined :: Int) +
        BS.length x
    poke x = do
        let (sourceFp, sourceOffset, sourceLength) = BS.toForeignPtr x
        poke sourceLength
        pokeFromForeignPtr sourceFp sourceOffset sourceLength
    peek = do
        len <- peek
        fp <- peekToPlainForeignPtr "Data.ByteString.ByteString" len
        return (BS.PS fp 0 len)

#if MIN_VERSION_template_haskell(2,16,0)
-- | Template Haskell Bytes are nearly identical to ByteString, but it
-- can't depend on ByteString.
instance Store Bytes where
    size = VarSize $ \x ->
        sizeOf (undefined :: Int) +
        fromIntegral (bytesSize x)
    poke (Bytes sourceFp sourceOffset sourceLength) = do
        poke sourceLength
        pokeFromForeignPtr sourceFp (fromIntegral sourceOffset) (fromIntegral sourceLength)
    peek = do
        len <- peek
        fp <- peekToPlainForeignPtr "Data.ByteString.ByteString" (fromIntegral len)
        return (Bytes fp 0 len)
#endif

instance Store SBS.ShortByteString where
    size = VarSize $ \x ->
         sizeOf (undefined :: Int) +
         SBS.length x
    poke x@(SBS.SBS arr) = do
        let len = SBS.length x
        poke len
        pokeFromByteArray arr 0 len
    peek = do
        len <- peek
        ByteArray array <- peekToByteArray "Data.ByteString.Short.ShortByteString" len
        return (SBS.SBS array)

instance Store LBS.ByteString where
    size = VarSize $ \x ->
         sizeOf (undefined :: Int)  +
         fromIntegral (LBS.length x)
    -- TODO: more efficient implementation that avoids the double copy
    poke = poke . LBS.toStrict
    peek = fmap LBS.fromStrict peek

instance Store T.Text where
#if MIN_VERSION_text(2,0,0)
    size = VarSize $ \x ->
        sizeOf (undefined :: Int) +
        T.lengthWord8 x
    poke x = do
        let !(T.Text (TA.ByteArray array) w8Off w8Len) = x
        poke w8Len
        pokeFromByteArray array w8Off w8Len
    peek = do
        w8Len <- peek
        ByteArray array <- peekToByteArray "Data.Text.Text" w8Len
        return (T.Text (TA.ByteArray array) 0 w8Len)
#else
    size = VarSize $ \x ->
        sizeOf (undefined :: Int) +
        2 * (T.lengthWord16 x)
    poke x = do
        let !(T.Text (TA.Array array) w16Off w16Len) = x
        poke w16Len
        pokeFromByteArray array (2 * w16Off) (2 * w16Len)
    peek = do
        w16Len <- peek
        ByteArray array <- peekToByteArray "Data.Text.Text" (2 * w16Len)
        return (T.Text (TA.Array array) 0 w16Len)
#endif

------------------------------------------------------------------------
-- Known size instances

newtype StaticSize (n :: Nat) a = StaticSize { unStaticSize :: a }
    deriving (Eq, Show, Ord, Data, Typeable, Generic)

instance NFData a => NFData (StaticSize n a)

class KnownNat n => IsStaticSize n a where
    toStaticSize :: a -> Maybe (StaticSize n a)

toStaticSizeEx :: IsStaticSize n a => a -> StaticSize n a
toStaticSizeEx x =
    case toStaticSize x of
        Just r -> r
        Nothing -> error "Failed to assert a static size via toStaticSizeEx"

instance KnownNat n => IsStaticSize n BS.ByteString where
    toStaticSize bs
        | BS.length bs == fromInteger (natVal (Proxy :: Proxy n)) = Just (StaticSize bs)
        | otherwise = Nothing

instance KnownNat n => Store (StaticSize n BS.ByteString) where
    size = ConstSize (fromInteger (natVal (Proxy :: Proxy n)))
    poke (StaticSize x) = do
        let (sourceFp, sourceOffset, sourceLength) = BS.toForeignPtr x
        pokeFromForeignPtr sourceFp sourceOffset sourceLength
    peek = do
        let len = fromInteger (natVal (Proxy :: Proxy n))
        fp <- peekToPlainForeignPtr ("StaticSize " ++ show len ++ " Data.ByteString.ByteString") len
        return (StaticSize (BS.PS fp 0 len))

-- NOTE: this could be a 'Lift' instance, but we can't use type holes in
-- TH. Alternatively we'd need a (TypeRep -> Type) function and Typeable
-- constraint.
liftStaticSize :: forall n a. (KnownNat n, Lift a) => TypeQ -> StaticSize n a -> ExpQ
liftStaticSize tyq (StaticSize x) = do
    let numTy = litT $ numTyLit $ natVal (Proxy :: Proxy n)
    [| StaticSize $(lift x) :: StaticSize $(numTy) $(tyq) |]

#if MIN_VERSION_template_haskell(2,17,0)
staticByteStringExp :: Quote m => BS.ByteString -> m Exp
#else
staticByteStringExp :: BS.ByteString -> ExpQ
#endif
staticByteStringExp bs =
    [| StaticSize bs :: StaticSize $(litT (numTyLit (fromIntegral len))) BS.ByteString |]
  where
    len = BS.length bs

------------------------------------------------------------------------
-- containers instances

instance Store a => Store [a] where
    size = sizeSequence
    poke = pokeSequence
    peek = peekSequence

instance Store a => Store (NE.NonEmpty a)

instance Store a => Store (Seq a) where
    size = sizeSequence
    poke = pokeSequence
    peek = peekSequence

instance (Store a, Ord a) => Store (Set a) where
    size =
        VarSize $ \t ->
            sizeOf (undefined :: Int) +
            case size of
                ConstSize n -> n * Set.size t
                VarSize f -> Set.foldl' (\acc a -> acc + f a) 0 t
    poke = pokeSet
    peek = Set.fromDistinctAscList <$> peek

instance Store IntSet where
    size = sizeSet
    poke = pokeSet
    peek = IntSet.fromDistinctAscList <$> peek

instance Store a => Store (IntMap a) where
    size = sizeOrdMap
    poke = pokeOrdMap
    peek = peekOrdMapWith IntMap.fromDistinctAscList

instance (Ord k, Store k, Store a) => Store (Map k a) where
    size =
        VarSize $ \t ->
            sizeOf markMapPokedInAscendingOrder + sizeOf (undefined :: Int) +
            case (size, size) of
                (ConstSize nk, ConstSize na) -> (nk + na) * Map.size t
                (szk, sza) ->
                    Map.foldlWithKey'
                        (\acc k a -> acc + getSizeWith szk k + getSizeWith sza a)
                        0
                        t
    poke = pokeOrdMap
    peek = peekOrdMapWith Map.fromDistinctAscList

instance (Eq k, Hashable k, Store k, Store a) => Store (HashMap k a) where
    size = sizeMap
    poke = pokeMap
    peek = peekMap

instance (Eq a, Hashable a, Store a) => Store (HashSet a) where
    size = sizeSet
    poke = pokeSet
    peek = peekSet

instance (A.Ix i, Store i, Store e) => Store (A.Array i e) where
    size = sizeArray
    poke = pokeArray
    peek = peekArray

instance (A.Ix i, A.IArray A.UArray e, Store i, Store e) => Store (A.UArray i e) where
    size = sizeArray
    poke = pokeArray
    peek = peekArray

sizeArray :: (A.Ix i, A.IArray a e, Store i, Store e) => Size (a i e)
sizeArray = VarSize $ \arr ->
    let bounds = A.bounds arr
    in  getSize bounds +
        case size of
            ConstSize n ->  n * A.rangeSize bounds
            VarSize f -> foldl' (\acc x -> acc + f x) 0 (A.elems arr)
{-# INLINE sizeArray #-}

pokeArray :: (A.Ix i, A.IArray a e, Store i, Store e) => a i e -> Poke ()
pokeArray arr = do
    poke (A.bounds arr)
    forM_ (A.elems arr) poke
{-# INLINE pokeArray #-}

peekArray :: (A.Ix i, A.IArray a e, Store i, Store e) => Peek (a i e)
peekArray = do
    bounds <- peek
    let len = A.rangeSize bounds
    elems <- replicateM len peek
    return (A.listArray bounds elems)
{-# INLINE peekArray #-}

instance Store Integer where
#ifdef INTEGER_GMP
#if MIN_VERSION_integer_gmp(1,0,0)
    size = VarSize $ \ x ->
        sizeOf (undefined :: Word8) + case x of
            I.S# _ -> sizeOf (undefined :: Int)
            I.Jp# (I.BN# arr) -> sizeOf (undefined :: Int) + I# (sizeofByteArray# arr)
            I.Jn# (I.BN# arr) -> sizeOf (undefined :: Int) + I# (sizeofByteArray# arr)
    poke (I.S# x) = poke (0 :: Word8) >> poke (I# x)
    poke (I.Jp# (I.BN# arr)) = do
        let len = I# (sizeofByteArray# arr)
        poke (1 :: Word8)
        poke len
        pokeFromByteArray arr 0 len
    poke (I.Jn# (I.BN# arr)) = do
        let len = I# (sizeofByteArray# arr)
        poke (2 :: Word8)
        poke len
        pokeFromByteArray arr 0 len
    peek = do
        tag <- peek :: Peek Word8
        case tag of
            0 -> fromIntegral <$> (peek :: Peek Int)
            1 -> I.Jp# <$> peekBN
            2 -> I.Jn# <$> peekBN
            _ -> peekException "Invalid Integer tag"
      where
        peekBN = do
          len <- peek :: Peek Int
          ByteArray arr <- peekToByteArray "GHC>Integer" len
          return $ I.BN# arr
#else
    -- May as well put in the extra effort to use the same encoding as
    -- used for the newer integer-gmp.
    size = VarSize $ \ x ->
        sizeOf (undefined :: Word8) + case x of
            I.S# _ -> sizeOf (undefined :: Int)
            I.J# sz _ -> sizeOf (undefined :: Int) + (I# sz) * sizeOf (undefined :: Word)
    poke (I.S# x) = poke (0 :: Word8) >> poke (I# x)
    poke (I.J# sz arr)
        | (I# sz) > 0 = do
            let len = I# sz * sizeOf (undefined :: Word)
            poke (1 :: Word8)
            poke len
            pokeFromByteArray arr 0 len
        | (I# sz) < 0 = do
            let len = negate (I# sz) * sizeOf (undefined :: Word)
            poke (2 :: Word8)
            poke len
            pokeFromByteArray arr 0 len
        | otherwise = do
            poke (0 :: Word8)
            poke (0 :: Int)
    peek = do
        tag <- peek :: Peek Word8
        case tag of
            0 -> fromIntegral <$> (peek :: Peek Int)
            1 -> peekJ False
            2 -> peekJ True
            _ -> peekException "Invalid Integer tag"
      where
        peekJ neg = do
          len <- peek :: Peek Int
          ByteArray arr <- peekToByteArray "GHC>Integer" len
          let (sz0, r) = len `divMod` (sizeOf (undefined :: Word))
              !(I# sz) = if neg then negate sz0 else sz0
          when (r /= 0) (peekException "Buffer size stored for encoded Integer not divisible by Word size (to get limb count).")
          return (I.J# sz arr)
#endif
#else
    -- NOTE: integer-simple uses a different encoding than GMP
    size = VarSize $ \ x ->
        sizeOf (undefined :: Word8) + case x of
            I.Positive ds -> (1 + fromIntegral (numDigits ds)) * sizeOf (undefined :: Word)
            I.Negative ds -> (1 + fromIntegral (numDigits ds)) * sizeOf (undefined :: Word)
            I.Naught -> 0
      where
    poke x = case x of
      I.Naught -> poke (0 :: Word8)
      I.Positive ds -> do
        poke (1 :: Word8)
        poke (numDigits ds)
        pokeDigits ds
      I.Negative ds -> do
        poke (2 :: Word8)
        poke (numDigits ds)
        pokeDigits ds
      where
        pokeDigits I.None = pure ()
        pokeDigits (I.Some d ds) = poke (W# d) *> pokeDigits ds
    peek = do
      tag <- peek :: Peek Word8
      case tag of
        0 -> pure I.Naught
        1 -> do
          len <- peek :: Peek Word
          I.Positive <$> peekDigits len
        2 -> do
          len <- peek :: Peek Word
          I.Negative <$> peekDigits len
        _ -> peekException "Invalid Integer tag"
      where
        peekDigits i
          | i <= 0 = pure I.None
          | otherwise = do
              W# d <- peek
              ds <- peekDigits (i - 1)
              pure $! I.Some d ds

numDigits :: I.Digits -> Word
numDigits = go 0
  where go !acc I.None = acc
        go !acc (I.Some _ ds) = go (acc + 1) ds
#endif

-- Piggybacks off of the Integer instance

instance Store Natural where
  size = contramap fromIntegral (size :: Size Integer)
  poke = poke . toInteger
  peek = do
      x <- peek :: Peek Integer
      if x < 0
          then peekException "Encountered negative integer when expecting a Natural"
          else return $ fromIntegral x

------------------------------------------------------------------------
-- Other instances

-- Manual implementation due to no Generic instance for Ratio. Also due
-- to the instance for Storable erroring when the denominator is 0.
-- Perhaps we should keep the behavior but instead a peekException?
--
-- In that case it should also error on poke.
--
-- I prefer being able to Store these, because they are constructable.

instance Store a => Store (Ratio a) where
    size = combineSize (\(x :% _) -> x) (\(_ :% y) -> y)
    poke (x :% y) = poke (x, y)
    peek = uncurry (:%) <$> peek

-- Similarly, manual implementation due to no Generic instance for
-- Complex and Identity in GHC-7.10 and earlier.

$($(derive [d| instance Deriving (Store (Fixed a)) |]))

instance Store Time.DiffTime where
    size = contramap (realToFrac :: Time.DiffTime -> Pico) size
    poke = poke . (realToFrac :: Time.DiffTime -> Pico)
    peek = (realToFrac :: Pico -> Time.DiffTime) <$> peek

instance Store Time.NominalDiffTime where
    size = contramap (realToFrac :: Time.NominalDiffTime -> Pico) size
    poke = poke . (realToFrac :: Time.NominalDiffTime -> Pico)
    peek = (realToFrac :: Pico -> Time.NominalDiffTime) <$> peek

instance Store ()
instance Store a => Store (Dual a)
instance Store a => Store (Sum a)
instance Store a => Store (Product a)
instance Store a => Store (First a)
instance Store a => Store (Last a)
instance Store a => Store (Maybe a)
instance Store a => Store (Const a b)

------------------------------------------------------------------------
-- Instances generated by TH

$($(derive [d|
    instance Store a => Deriving (Store (Complex a))
    instance Store a => Deriving (Store (Identity a))

    instance Deriving (Store All)
    instance Deriving (Store Any)
    instance Deriving (Store Void)
    instance Deriving (Store Bool)
    instance (Store a, Store b) => Deriving (Store (Either a b))

    instance Deriving (Store Time.AbsoluteTime)
    instance Deriving (Store Time.Day)
    instance Deriving (Store Time.LocalTime)
    instance Deriving (Store Time.TimeOfDay)
    instance Deriving (Store Time.TimeZone)
    instance Deriving (Store Time.UTCTime)
    instance Deriving (Store Time.UniversalTime)
    instance Deriving (Store Time.ZonedTime)
    instance Deriving (Store Time.TimeLocale)

#if MIN_VERSION_time(1,8,0)
    instance Deriving (Store Time.SystemTime)
#endif

#if MIN_VERSION_time(1,9,0)
    instance Deriving (Store Time.CalendarDiffDays)
    instance Deriving (Store Time.CalendarDiffTime)
    instance Deriving (Store Time.FormatExtension)
#endif

#if MIN_VERSION_time(1,11,0)
    instance Deriving (Store Time.DayOfWeek)
    instance Deriving (Store Time.FirstWeekType)
    instance Deriving (Store Time.Quarter)
    instance Deriving (Store Time.QuarterOfYear)
#endif

    |]))

$(deriveManyStorePrimVector)

$(deriveManyStoreUnboxVector)

$(deriveManyStoreFromStorable
  -- TODO: Figure out why on GHC-8.2.1 this internal datatype is visible
  -- in the instances of Storable. Here's a gist of an attempt at
  -- debugging the issue:
  --
  -- https://gist.github.com/mgsloan/a7c416b961015949d3b5674ce053bbf6
  --
  -- The mysterious thing is why this is happening despite not having a
  -- direct import of Data.Text.Encoding.
  (\ty ->
    case ty of
      ConT n | nameModule n == Just "Data.Text.Encoding"
            && nameBase n == "DecoderState" -> False
      ConT n | nameModule n == Just "Data.Text.Encoding"
            && nameBase n == "CodePoint" -> False
      ConT n | nameModule n == Just "Network.Socket.Types"
            && nameBase n == "In6Addr" -> False
      -- AddrInfo's Storable instance is lossy, so avoid having a Store
      -- instance for it.
      ConT n | n == ''AddrInfo -> False
      _ -> True
    ))

$(reifyManyWithoutInstances ''Store [''ModName, ''NameSpace, ''PkgName] (const True) >>=
   mapM (\name -> return (deriveGenericInstance [] (ConT name))))

-- Explicit definition needed because in template-haskell <= 2.9 (GHC
-- 7.8), NameFlavour contains unboxed values, causing generic deriving
-- to fail.
#if !MIN_VERSION_template_haskell(2,10,0)
instance Store NameFlavour where
    size = VarSize $ \x -> getSize (0 :: Word8) + case x of
        NameS -> 0
        NameQ mn -> getSize mn
        NameU i -> getSize (I# i)
        NameL i -> getSize (I# i)
        NameG ns pn mn -> getSize ns + getSize pn + getSize mn
    poke NameS = poke (0 :: Word8)
    poke (NameQ mn) = do
        poke (1 :: Word8)
        poke mn
    poke (NameU i) = do
        poke (2 :: Word8)
        poke (I# i)
    poke (NameL i) = do
        poke (3 :: Word8)
        poke (I# i)
    poke (NameG ns pn mn) = do
        poke (4 :: Word8)
        poke ns
        poke pn
        poke mn
    peek = do
        tag <- peek
        case tag :: Word8 of
            0 -> return NameS
            1 -> NameQ <$> peek
            2 -> do
                !(I# i) <- peek
                return (NameU i)
            3 -> do
                !(I# i) <- peek
                return (NameL i)
            4 -> NameG <$> peek <*> peek <*> peek
            _ -> peekException "Invalid NameFlavour tag"
#endif

$(reifyManyWithoutInstances ''Store [''Info] (const True) >>=
   mapM deriveGenericInstanceFromName)


-- |
-- Module      : Southpaw.Interactive.Lenses
-- Description :
-- Copyright   : (c) Jonatan H Sundqvist, 2015
-- License     : MIT
-- Maintainer  : Jonatan H Sundqvist
-- Stability   : experimental|stable
-- Portability : POSIX (not sure)
--

-- Created October 15 2015

-- TODO | -
--        -

-- SPEC | -
--        -

--------------------------------------------------------------------------------------------------------------------------------------------
-- GHC Pragmas
--------------------------------------------------------------------------------------------------------------------------------------------

--------------------------------------------------------------------------------------------------------------------------------------------
-- API
--------------------------------------------------------------------------------------------------------------------------------------------
module Southpaw.Interactive.Lenses where

--------------------------------------------------------------------------------------------------------------------------------------------
-- We'll need these
--------------------------------------------------------------------------------------------------------------------------------------------
import Data.IORef
import Data.Complex
import Data.Functor ((<$>))
import Control.Lens

import Graphics.UI.Gtk
import qualified Graphics.Rendering.Cairo as Cairo

import qualified Southpaw.Interactive.Types as App

--------------------------------------------------------------------------------------------------------------------------------------------
-- Lenses
--------------------------------------------------------------------------------------------------------------------------------------------

-- App -------------------------------------------------------------------------------------------------------------------------------------

window :: Lens (App.App layout state) (App.App layout state) Window Window
window f s = (\new -> s { App._window=new }) <$> f (App._window s)

layout :: Lens (App.App layout state) (App.App layout state) layout layout
layout f s = (\new -> s { App._layout=new }) <$> f (App._layout s)

-- TODO: Make this a getter (since setting this property won't affect the windw size) (?)
size :: Lens (App.App layout state) (App.App layout state) (Complex Int) (Complex Int)
size f s = (\new -> s { App._appsize=new }) <$> f (App._appsize s)

state :: Lens (App.App layout state) (App.App layout state) (IORef state) (IORef state)
state f s = (\new -> s { App._state=new }) <$> f (App._state s)

-- CanvasLayout ----------------------------------------------------------------------------------------------------------------------------

canvas :: Lens (App.FullCanvasLayout) (App.FullCanvasLayout) (DrawingArea) (DrawingArea)
canvas f s = (\new -> s { App._canvas=new }) <$> f (App._canvas s)

-- Settings --------------------------------------------------------------------------------------------------------------------------------

-- Generic ---------------------------------------------------------------------------------------------------------------------------------


{-# LANGUAGE DeriveGeneric, DeriveAnyClass, BangPatterns #-}

module Report where

import           Control.DeepSeq
import           Control.Monad
import           Criterion.IO
import           Criterion.Types
import           Data.List
import qualified Data.Map                      as M
import           Data.Maybe
import           GHC.Generics
import           Statistics.Types
import           System.Directory
import           System.FilePath
import           Text.Printf
import           Data.Bifunctor
import           Data.Char

-- | Map test names to test measures
type Measures = M.Map String Measure

data Measure = Measure
  { mTest :: String -- ^Test name, with the format <test-kind>/<test-obj>-<test-pkg>
  , mValue :: Double -- ^Execution time (in ms or bytes, depending on the test)
  } deriving (Show, Read, Eq, Generic, NFData, Ord)

{- |
>>> import Data.List
>>> let m = Measure "deserialization (time)/BinTree Direction-binary" 1989
>>> let m2 = Measure "serialization (time)/BinTree Direction-binary" 1004
>>> let m3 = Measure "size (bytes)/BinTree Direction-binary" 6291455
>>> let m4 = Measure "size (bytes)/Cars-binary" 301455
>>> let m5 = Measure "size (bytes)/Cars-flat" 300000
>>> let ms = measures [m,m2,m3,m4,m5]

>>> mKindPkg m
("deserialization (time)/BinTree Direction","binary")

>>> mKindPkgVal m
("deserialization (time)/BinTree Direction",("binary",1989.0))

>>> mKind m
"deserialization (time)/BinTree Direction"

>>> mObj m
"BinTree Direction"

>>> mObjSub m
"BinTree Direction-binary"

>>> mSub m
"binary"

>>> allOf mObj ms
["BinTree Direction","Cars"]

>>> allOf mType ms
["deserialization (time)","serialization (time)","size (bytes)"]

>>> summaryTable ms
[("BinTree Direction",[("deserialization (time)",[(1989.0,[Measure {mTest = "deserialization (time)/BinTree Direction-binary", mValue = 1989.0}])]),("serialization (time)",[(1004.0,[Measure {mTest = "serialization (time)/BinTree Direction-binary", mValue = 1004.0}])]),("size (bytes)",[(6291455.0,[Measure {mTest = "size (bytes)/BinTree Direction-binary", mValue = 6291455.0}])])]),("Cars",[("size (bytes)",[(300000.0,[Measure {mTest = "size (bytes)/Cars-flat", mValue = 300000.0}]),(301455.0,[Measure {mTest = "size (bytes)/Cars-binary", mValue = 301455.0}])])])]

>>> renderTable ms
"|Dataset\\Measure|deserialization|serialization|size|\n| ---| ---| ---| ---|\n|BinTree Direction|[binary](https://hackage.haskell.org/package/binary)|[binary](https://hackage.haskell.org/package/binary)|[binary](https://hackage.haskell.org/package/binary)|\n|Cars|||[flat](https://hackage.haskell.org/package/flat),[binary](https://hackage.haskell.org/package/binary)|\n"

>>> addTransfers_ ms
fromList [("deserialization (time)/BinTree Direction-binary",Measure {mTest = "deserialization (time)/BinTree Direction-binary", mValue = 1989.0}),("serialization (time)/BinTree Direction-binary",Measure {mTest = "serialization (time)/BinTree Direction-binary", mValue = 1004.0}),("size (bytes)/BinTree Direction-binary",Measure {mTest = "size (bytes)/BinTree Direction-binary", mValue = 6291455.0}),("size (bytes)/Cars-binary",Measure {mTest = "size (bytes)/Cars-binary", mValue = 301455.0}),("size (bytes)/Cars-flat",Measure {mTest = "size (bytes)/Cars-flat", mValue = 300000.0}),("transfer [10 MBits] (time)/BinTree Direction-binary",Measure {mTest = "transfer [10 MBits] (time)/BinTree Direction-binary", mValue = 8026.164}),("transfer [100 MBits] (time)/BinTree Direction-binary",Measure {mTest = "transfer [100 MBits] (time)/BinTree Direction-binary", mValue = 3496.3164}),("transfer [1000 MBits] (time)/BinTree Direction-binary",Measure {mTest = "transfer [1000 MBits] (time)/BinTree Direction-binary", mValue = 3043.33164})]
-}
renderTable :: Measures -> String
renderTable ms =
  let
    tests = allOf mObj ms
    kinds = allOf mType ms
    vals  = allOf mSub ms
    lines s = s : map (\t -> showPkgs $ map (\v -> tos t s v ms) vals) kinds
  in
    unlines
    . map mdRow
    $ ("Dataset\\Measure" : map short kinds)
    : replicate (length kinds + 1) " ---"
    : map lines tests
 where
  pkgVals = map snd . tops . sort . catMaybes . map
    ((\m -> (mValue m, pkgRef $ mSub m)) <$>)
  tops [] = []
  tops hs =
    let limit = fst (head hs) * 1.3 in takeWhile (\e -> fst e <= limit) hs
  showPkgs = intercalate "," . pkgVals
  mdRow vs = concat ["|", intercalate "|" vs, "|"]
  pkgRef name =
    concat ["[", name, "](https://hackage.haskell.org/package/", name, ")"]
  short = unwords . init . words

tos :: String -> String -> String -> Measures -> Maybe Measure
tos t o s ms = M.lookup (concat [t, "/", o, "-", s]) ms

summaryTable :: M.Map k Measure -> [(String, [(String, [(Double, [Measure])])])]
summaryTable =
  map (second $ (map (second $ by mValue) . by mType)) . by mObj . M.elems

addTransfers :: FilePath -> IO ()
addTransfers workDir = addMeasures__ workDir addTransfers_ >> return ()

addTransfers_ :: Measures -> Measures
addTransfers_ ms =
  let
    tests = allOf mObjSub ms
    addT :: Measures -> String -> Measures
    addT ms o =
      fromMaybe ms
        $   (\ser des siz ->
              let
                add1 :: Double -> Measures -> Measures
                add1 megaBits ms =
                  let
                    trans =
                      concat
                        [ "transfer ["
                        , show (round megaBits :: Integer)
                        , " MBits] (time)/"
                        , o
                        ]
                    time =
                      mValue ser + mValue des + mValue siz * 8 / (megaBits * 1000)
                  in
                    add (Measure trans time) ms
              in
                add1 1000 (add1 100 (add1 10 ms))
            )
        <$> M.lookup ("serialization (time)/" ++ o) ms
        <*> M.lookup ("deserialization (time)/" ++ o) ms
        <*> M.lookup ("size (bytes)/" ++ o) ms
  in
    foldl addT ms tests

add :: Measure -> Measures -> Measures
add m = M.insert (mTest m) m

mKindPkg :: Measure -> (String, String)
mKindPkg m = let (k, _ : p) = break (== '-') $ mTest m in (k, p)

mKind :: Measure -> String
mKind = fst . mKindPkg

mType :: Measure -> String
mType = brk1 '/' . mKind

mObj :: Measure -> String
mObj = brk2 '/' . mKind

mObjSub :: Measure -> String
mObjSub = brk2 '/' . mTest

mSub :: Measure -> String
mSub = brk2 '-' . mObjSub

brk1 :: Eq a => a -> [a] -> [a]
brk1 sep = fst . break (== sep)

brk2 :: Eq a => a -> [a] -> [a]
brk2 sep = tail . snd . break (== sep)

mKindPkgVal :: Measure -> (String, (String, Double))
mKindPkgVal m = let (k, p) = mKindPkg m in (k, (p, mValue m))

byTestKind :: Measures -> [(String, (String, Double))]
byTestKind = map mKindPkgVal . M.elems

allKinds :: Measures -> [String]
allKinds = allOf mKind

allOf :: Eq a1 => (a2 -> a1) -> M.Map k a2 -> [a1]
allOf f = nub . map f . M.elems

allTests :: [(String, (String, Double))] -> [(String, [(String, Double)])]
allTests = -- by fst
           sort . map (\g -> (fst . head $ g, map snd g)) . groupBy
  (\a b -> fst a == fst b)

-- order by dimension
by :: (Ord a, Ord t) => (t -> a) -> [t] -> [(a, [t])]
by f = sort . map (\g -> (f $ head g, g)) . groupBy (\a b -> f a == f b)

toMeasures :: [Report] -> Measures
toMeasures = measures . map toMeasure

measures :: [Measure] -> Measures
measures = M.fromList . map (\m -> (mTest m, m))

toMeasure :: Report -> Measure
toMeasure r =
  Measure (reportName r) ((1000 *) . estPoint . anMean . reportAnalysis $ r)

deleteMeasures :: FilePath -> IO ()
deleteMeasures = removeFile . measuresFile

updateMeasures :: FilePath -> IO ()
updateMeasures = void . updateMeasures_

updateMeasures_ :: FilePath -> IO (Measures, Measures, Measures)
updateMeasures_ dir = do
  m' <- readCriterionMeasures dir
  addMeasures_ dir m'

addMeasures_ :: FilePath -> Measures -> IO (Measures, Measures, Measures)
addMeasures_ dir m' = addMeasures__ dir (const m')

addMeasures__
  :: FilePath -> (Measures -> Measures) -> IO (Measures, Measures, Measures)
addMeasures__ dir f = do
  !m <- readMeasures dir
  let m'  = f m
  let m'' = M.union m' m
  writeMeasures dir m''
  return (m, m', m'')

addMeasures :: FilePath -> String -> [(String, Double)] -> IO ()
addMeasures dir name ms = void $ addMeasures_
  dir
  (M.fromList $ map
    (\(pkg, val) -> let n = concat [name, "-", pkg] in (n, Measure n val))
    ms
  )

readMeasures :: FilePath -> IO Measures
readMeasures dir = do
  let f = measuresFile dir
  fe <- doesFileExist f
  if not fe then return M.empty else (force . read) <$> readFile f

writeMeasures :: FilePath -> Measures -> IO ()
writeMeasures dir = writeFile (measuresFile dir) . show

readCriterionMeasures :: FilePath -> IO Measures
readCriterionMeasures dir = toMeasures <$> readReports (reportsFile dir)

measuresFile :: FilePath -> FilePath
measuresFile dir = dir </> "measures"

reportsFile :: FilePath -> FilePath
reportsFile dir = dir </> "report.json"

reportsMDFile :: FilePath -> FilePath
reportsMDFile dir = dir </> "report.md"

printMeasures :: FilePath -> IO ()
printMeasures dir = reportMeasures_ dir >>= putStrLn

printSummary :: FilePath -> (String -> Bool) -> IO ()
printSummary dir f =
  readMeasures dir >>= putStrLn . renderTable . M.filter (f . mTest)

reportMeasures :: FilePath -> IO ()
reportMeasures dir =
  reportMeasures_ dir
    >>= writeFile (reportsMDFile dir)
    . ("Results that are within 30% of the best result are displayed in **bold**.\n\n" ++
      )

reportMeasures_ :: FilePath -> IO String
reportMeasures_ dir = reportMeasures__ (const True) <$> readMeasures dir

printMeasuresCurrent :: (Measures, Measures, Measures) -> IO ()
printMeasuresCurrent (_, m', m'') =
  let currentKinds = allKinds m'
  in  printMeasuresAll_ (\ts -> fst ts `elem` currentKinds) m''

printMeasuresAll_ :: ((String, [(String, Double)]) -> Bool) -> Measures -> IO ()
printMeasuresAll_ f = putStrLn . reportMeasures__ f

reportMeasures__ :: ((String, [(String, Double)]) -> Bool) -> Measures -> String
reportMeasures__ f =
  concatMap (uncurry report) . filter f . allTests . byTestKind

printMeasuresDiff :: (Measures, Measures, Measures) -> IO ()
printMeasuresDiff (m, m', _) =
  mapM_ (\(n, d) -> putStrLn (unwords [n, show d, "%"]))
    . M.toList
    $ M.intersectionWith
        (\a b -> round ((mValue b / mValue a - 1) * 100) :: Int)
        m
        m'

readReports :: FilePath -> IO [Report]
readReports jsonReportFile = do
  fe <- doesFileExist jsonReportFile
  if not fe
    then return [] -- M.empty
    else do
      er <- readJSONReports jsonReportFile
      return $ case er of
        Right (_, _, reports) -> reports
        _                     -> [] -- M.empty

report :: String -> [(String, Double)] -> String
report _ [] = []
report name rs =
  let (_, rss) = report_ rs
      width    = maximum . map (length . fst) $ rs
      out =
        [ "| ---| ---|"
        , "| package | performance |"
        , ""
        , unwords ["####", name, "(best first)"]
        ]
          -- out = ["| ---| ---| ---|","| package | measure | relative measure |","",unwords ["####",name, "(best first)"]]
  in  unlines
      . reverse
      $ ""
      : foldl'
          (\out (n, r, a) ->
            let bold n = concat ["**", n, "**"]
                marked n = -- fix prob with github bold display
                           if r <= 1.3
                  then if isSpace (head n)
                    then let (n1, n2) = span isSpace n in n1 ++ bold n2
                    else
                      let (n1, n2) = span (not . isSpace) n in bold n1 ++ n2
                  else n
            in  unwords
                    [ "|"
                    , marked (printString width n) -- pkg name
                    , "|"
                  -- , printf "%11.1f" a -- absolute measure
                  -- ,"|"
                    , marked (printDouble r) -- relative measure
                    , "|"
                    ]
                  : out
          )
          out
          rss

report_ :: (Fractional c, Ord c) => [(a, c)] -> ((a, c), [(a, c, c)])
report_ rs =
  let rss  = sortOn snd rs
      best = snd . head $ rss
  in  (head rss, map (\(n, v) -> (n, v / best, v)) rss)

printDouble :: Double -> String
printDouble = printf "%7.1f"

printInt :: Double -> String
printInt = printf "%.0f"

printString :: Int -> String -> String
printString width = printf ("%-" ++ show width ++ "s")


{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE MagicHash #-}

#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE Trustworthy #-}
#endif

#if __GLASGOW_HASKELL__ >= 705
{-# LANGUAGE PolyKinds #-}
#endif

#include "HsBaseConfig.h"

module Generics.Deriving.Eq (
  -- * Generic Eq class
    GEq(..)

  -- * Default definition
  , geqdefault

  -- * Internal Eq class
  , GEq'(..)

  ) where

import           Control.Applicative (Const, ZipList)

import           Data.Char (GeneralCategory)
import           Data.Int
import qualified Data.Monoid as Monoid (First, Last)
import           Data.Monoid (All, Any, Dual, Product, Sum)
import           Data.Version (Version)
import           Data.Word

import           Foreign.C.Error
import           Foreign.C.Types
import           Foreign.ForeignPtr (ForeignPtr)
import           Foreign.Ptr
import           Foreign.StablePtr (StablePtr)

import           Generics.Deriving.Base

import           GHC.Exts hiding (Any)

import           System.Exit (ExitCode)
import           System.IO (BufferMode, Handle, HandlePosn, IOMode, SeekMode)
import           System.IO.Error (IOErrorType)
import           System.Posix.Types

#if MIN_VERSION_base(4,4,0)
import           Data.Complex (Complex)
#endif

#if MIN_VERSION_base(4,7,0)
import           Data.Proxy (Proxy)
#endif

#if MIN_VERSION_base(4,8,0)
import           Data.Functor.Identity (Identity)
import           Data.Monoid (Alt)
import           Data.Void (Void)
import           Numeric.Natural (Natural)
#endif

#if MIN_VERSION_base(4,9,0)
import           Data.List.NonEmpty (NonEmpty)
import qualified Data.Semigroup as Semigroup (First, Last)
import           Data.Semigroup (Arg(..), Max, Min, WrappedMonoid)
#endif

--------------------------------------------------------------------------------
-- Generic show
--------------------------------------------------------------------------------

class GEq' f where
  geq' :: f a -> f a -> Bool

instance GEq' V1 where
  geq' _ _ = True

instance GEq' U1 where
  geq' _ _ = True

instance (GEq c) => GEq' (K1 i c) where
  geq' (K1 a) (K1 b) = geq a b

-- No instances for P or Rec because geq is only applicable to types of kind *

instance (GEq' a) => GEq' (M1 i c a) where
  geq' (M1 a) (M1 b) = geq' a b

instance (GEq' a, GEq' b) => GEq' (a :+: b) where
  geq' (L1 a) (L1 b) = geq' a b
  geq' (R1 a) (R1 b) = geq' a b
  geq' _      _      = False

instance (GEq' a, GEq' b) => GEq' (a :*: b) where
  geq' (a1 :*: b1) (a2 :*: b2) = geq' a1 a2 && geq' b1 b2

-- Unboxed types
instance GEq' UAddr where
  geq' (UAddr a1) (UAddr a2)     = isTrue# (eqAddr# a1 a2)
instance GEq' UChar where
  geq' (UChar c1) (UChar c2)     = isTrue# (eqChar# c1 c2)
instance GEq' UDouble where
  geq' (UDouble d1) (UDouble d2) = isTrue# (d1 ==## d2)
instance GEq' UFloat where
  geq' (UFloat f1) (UFloat f2)   = isTrue# (eqFloat# f1 f2)
instance GEq' UInt where
  geq' (UInt i1) (UInt i2)       = isTrue# (i1 ==# i2)
instance GEq' UWord where
  geq' (UWord w1) (UWord w2)     = isTrue# (eqWord# w1 w2)

#if !(MIN_VERSION_base(4,7,0))
isTrue# :: Bool -> Bool
isTrue# = id
#endif

class GEq a where
  geq :: a -> a -> Bool

#if __GLASGOW_HASKELL__ >= 701
  default geq :: (Generic a, GEq' (Rep a)) => a -> a -> Bool
  geq = geqdefault
#endif

geqdefault :: (Generic a, GEq' (Rep a)) => a -> a -> Bool
geqdefault x y = geq' (from x) (from y)

-- Base types instances
instance GEq () where
  geq = geqdefault

instance (GEq a, GEq b) => GEq (a, b) where
  geq = geqdefault

instance (GEq a, GEq b, GEq c) => GEq (a, b, c) where
  geq = geqdefault

instance (GEq a, GEq b, GEq c, GEq d) => GEq (a, b, c, d) where
  geq = geqdefault

instance (GEq a, GEq b, GEq c, GEq d, GEq e) => GEq (a, b, c, d, e) where
  geq = geqdefault

instance (GEq a, GEq b, GEq c, GEq d, GEq e, GEq f)
    => GEq (a, b, c, d, e, f) where
  geq = geqdefault

instance (GEq a, GEq b, GEq c, GEq d, GEq e, GEq f, GEq g)
    => GEq (a, b, c, d, e, f, g) where
  geq = geqdefault

instance GEq a => GEq [a] where
  geq = geqdefault

instance (GEq (f p), GEq (g p)) => GEq ((f :+: g) p) where
  geq = geqdefault

instance (GEq (f p), GEq (g p)) => GEq ((f :*: g) p) where
  geq = geqdefault

instance GEq (f (g p)) => GEq ((f :.: g) p) where
  geq = geqdefault

instance GEq All where
  geq = geqdefault

#if MIN_VERSION_base(4,8,0)
instance GEq (f a) => GEq (Alt f a) where
  geq = geqdefault
#endif

instance GEq Any where
  geq = geqdefault

#if !(MIN_VERSION_base(4,9,0))
instance GEq Arity where
  geq = geqdefault
#endif

#if MIN_VERSION_base(4,9,0)
instance GEq a => GEq (Arg a b) where
  geq (Arg a _) (Arg b _) = geq a b
#endif

instance GEq Associativity where
  geq = geqdefault

instance GEq Bool where
  geq = geqdefault

instance GEq BufferMode where
  geq = (==)

#if defined(HTYPE_CC_T)
instance GEq CCc where
  geq = (==)
#endif

instance GEq CChar where
  geq = (==)

instance GEq CClock where
  geq = (==)

#if defined(HTYPE_DEV_T)
instance GEq CDev where
  geq = (==)
#endif

instance GEq CDouble where
  geq = (==)

instance GEq CFloat where
  geq = (==)

#if defined(HTYPE_GID_T)
instance GEq CGid where
  geq = (==)
#endif

instance GEq Char where
  geq = (==)

#if defined(HTYPE_INO_T)
instance GEq CIno where
  geq = (==)
#endif

instance GEq CInt where
  geq = (==)

instance GEq CIntMax where
  geq = (==)

instance GEq CIntPtr where
  geq = (==)

instance GEq CLLong where
  geq = (==)

instance GEq CLong where
  geq = (==)

#if defined(HTYPE_MODE_T)
instance GEq CMode where
  geq = (==)
#endif

#if defined(HTYPE_NLINK_T)
instance GEq CNlink where
  geq = (==)
#endif

#if defined(HTYPE_OFF_T)
instance GEq COff where
  geq = (==)
#endif

#if MIN_VERSION_base(4,4,0)
instance GEq a => GEq (Complex a) where
  geq = geqdefault
#endif

instance GEq a => GEq (Const a b) where
  geq = geqdefault

#if defined(HTYPE_PID_T)
instance GEq CPid where
  geq = (==)
#endif

instance GEq CPtrdiff where
  geq = (==)

#if defined(HTYPE_RLIM_T)
instance GEq CRLim where
  geq = (==)
#endif

instance GEq CSChar where
  geq = (==)

#if defined(HTYPE_SPEED_T)
instance GEq CSpeed where
  geq = (==)
#endif

#if MIN_VERSION_base(4,4,0)
instance GEq CSUSeconds where
  geq = (==)
#endif

instance GEq CShort where
  geq = (==)

instance GEq CSigAtomic where
  geq = (==)

instance GEq CSize where
  geq = (==)

#if defined(HTYPE_SSIZE_T)
instance GEq CSsize where
  geq = (==)
#endif

#if defined(HTYPE_TCFLAG_T)
instance GEq CTcflag where
  geq = (==)
#endif

instance GEq CTime where
  geq = (==)

instance GEq CUChar where
  geq = (==)

#if defined(HTYPE_UID_T)
instance GEq CUid where
  geq = (==)
#endif

instance GEq CUInt where
  geq = (==)

instance GEq CUIntMax where
  geq = (==)

instance GEq CUIntPtr where
  geq = (==)

instance GEq CULLong where
  geq = (==)

instance GEq CULong where
  geq = (==)

#if MIN_VERSION_base(4,4,0)
instance GEq CUSeconds where
  geq = (==)
#endif

instance GEq CUShort where
  geq = (==)

instance GEq CWchar where
  geq = (==)

#if MIN_VERSION_base(4,9,0)
instance GEq DecidedStrictness where
  geq = geqdefault
#endif

instance GEq Double where
  geq = (==)

instance GEq a => GEq (Down a) where
  geq = geqdefault

instance GEq a => GEq (Dual a) where
  geq = geqdefault

instance (GEq a, GEq b) => GEq (Either a b) where
  geq = geqdefault

instance GEq Errno where
  geq = (==)

instance GEq ExitCode where
  geq = geqdefault

instance GEq Fd where
  geq = (==)

instance GEq a => GEq (Monoid.First a) where
  geq = geqdefault

#if MIN_VERSION_base(4,9,0)
instance GEq a => GEq (Semigroup.First a) where
  geq = geqdefault
#endif

instance GEq Fixity where
  geq = geqdefault

instance GEq Float where
  geq = (==)

instance GEq (ForeignPtr a) where
  geq = (==)

instance GEq (FunPtr a) where
  geq = (==)

instance GEq GeneralCategory where
  geq = (==)

instance GEq Handle where
  geq = (==)

instance GEq HandlePosn where
  geq = (==)

#if MIN_VERSION_base(4,8,0)
instance GEq a => GEq (Identity a) where
  geq = geqdefault
#endif

instance GEq Int where
  geq = (==)

instance GEq Int8 where
  geq = (==)

instance GEq Int16 where
  geq = (==)

instance GEq Int32 where
  geq = (==)

instance GEq Int64 where
  geq = (==)

instance GEq Integer where
  geq = (==)

instance GEq IntPtr where
  geq = (==)

instance GEq IOError where
  geq = (==)

instance GEq IOErrorType where
  geq = (==)

instance GEq IOMode where
  geq = (==)

instance GEq c => GEq (K1 i c p) where
  geq = geqdefault

instance GEq a => GEq (Monoid.Last a) where
  geq = geqdefault

#if MIN_VERSION_base(4,9,0)
instance GEq a => GEq (Semigroup.Last a) where
  geq = geqdefault
#endif

instance GEq (f p) => GEq (M1 i c f p) where
  geq = geqdefault

instance GEq a => GEq (Maybe a) where
  geq = geqdefault

#if MIN_VERSION_base(4,9,0)
instance GEq a => GEq (Max a) where
  geq = geqdefault

instance GEq a => GEq (Min a) where
  geq = geqdefault
#endif

#if MIN_VERSION_base(4,8,0)
instance GEq Natural where
  geq = (==)
#endif

#if MIN_VERSION_base(4,9,0)
instance GEq a => GEq (NonEmpty a) where
  geq = geqdefault
#endif

instance GEq Ordering where
  geq = geqdefault

instance GEq p => GEq (Par1 p) where
  geq = geqdefault

instance GEq a => GEq (Product a) where
  geq = geqdefault

#if MIN_VERSION_base(4,7,0)
instance GEq
# if MIN_VERSION_base(4,9,0)
             (Proxy s)
# else
             (Proxy (s :: *))
# endif
             where
  geq = geqdefault
#endif

instance GEq (Ptr a) where
  geq = (==)

instance GEq (f p) => GEq (Rec1 f p) where
  geq = geqdefault

instance GEq SeekMode where
  geq = (==)

instance GEq (StablePtr a) where
  geq = (==)

#if MIN_VERSION_base(4,9,0)
instance GEq SourceStrictness where
  geq = geqdefault

instance GEq SourceUnpackedness where
  geq = geqdefault
#endif

instance GEq a => GEq (Sum a) where
  geq = geqdefault

instance GEq (U1 p) where
  geq = geqdefault

instance GEq (UAddr p) where
  geq = geqdefault

instance GEq (UChar p) where
  geq = geqdefault

instance GEq (UDouble p) where
  geq = geqdefault

instance GEq (UFloat p) where
  geq = geqdefault

instance GEq (UInt p) where
  geq = geqdefault

instance GEq (UWord p) where
  geq = geqdefault

instance GEq Version where
  geq = (==)

#if MIN_VERSION_base(4,8,0)
instance GEq Void where
  geq = (==)
#endif

instance GEq Word where
  geq = (==)

instance GEq Word8 where
  geq = (==)

instance GEq Word16 where
  geq = (==)

instance GEq Word32 where
  geq = (==)

instance GEq Word64 where
  geq = (==)

instance GEq WordPtr where
  geq = (==)

#if MIN_VERSION_base(4,9,0)
instance GEq m => GEq (WrappedMonoid m) where
  geq = geqdefault
#endif

instance GEq a => GEq (ZipList a) where
  geq = geqdefault

#if MIN_VERSION_base(4,10,0)
instance GEq CBool where
  geq = (==)

# if defined(HTYPE_BLKSIZE_T)
instance GEq CBlkSize where
  geq = (==)
# endif

# if defined(HTYPE_BLKCNT_T)
instance GEq CBlkCnt where
  geq = (==)
# endif

# if defined(HTYPE_CLOCKID_T)
instance GEq CClockId where
  geq = (==)
# endif

# if defined(HTYPE_FSBLKCNT_T)
instance GEq CFsBlkCnt where
  geq = (==)
# endif

# if defined(HTYPE_FSFILCNT_T)
instance GEq CFsFilCnt where
  geq = (==)
# endif

# if defined(HTYPE_ID_T)
instance GEq CId where
  geq = (==)
# endif

# if defined(HTYPE_KEY_T)
instance GEq CKey where
  geq = (==)
# endif

# if defined(HTYPE_TIMER_T)
instance GEq CTimer where
  geq = (==)
# endif
#endif


{-# LANGUAGE TemplateHaskell #-}
import System.Environment (getArgs)
import Control.Monad (mapM)
import Text.PrettyPrint.Mainland
import qualified Data.ByteString.Char8 as B
import qualified Language.C.Syntax as C
import qualified Language.C.Parser as P
import Data.Loc
import Language.Haskell.TH
import Foreign.Ptr
import Foreign.C.Types
import Data.Char

{-
note: does not yet conform to the ffi style of hOpenBLAS,
also needs language c quote to work

-}

-- | Parse the file in the argument, transform it, then pretty print it.
main :: IO ()
main = do
    args <- getArgs
    let fname = head args
    x <- parseFile fname
    writeFile (take (length fname - 1) fname ++ "hs")
              $ (++) required
              $ pprint
              $ x >>= transform fname

-- | Parses C headers
parseFile :: String -> IO [C.Definition]
parseFile filename = do
    let start = startPos filename
    let exts = []
    s <- B.readFile filename
    case P.parse exts [] P.parseUnit s start of
      Left err   -> error $ show err
      Right defs -> return defs

required :: String
required = "{-# LANGUAGE GeneralizedNewtypeDeriving #-}\nmodule Numerical.OpenBLAS.FFI where\nimport Foreign.Ptr\nimport Foreign.C.Types\nimport Data.Complex\n"

-- wow! 1-1 mapping
transform :: String -> C.Definition -> [Dec]
transform headerName (C.DecDef (C.InitGroup (C.DeclSpec _ _ retType _) _ [C.Init (C.Id functionName _) (C.Proto _ (C.Params argsDecl _ _) _) _ _ _ _] _) sd)
  = let ty = case argsDecl of
              [(C.Param _ (C.DeclSpec _ _ (C.Tvoid _) _) _ _)] -> (AppT (ConT (mkName "IO")) $ tyco retType)
              xs -> foldnconquer (AppT (ConT (mkName "IO")) $ tyco retType) $ paramify xs
        f = ForeignD
          $ ImportF CCall Unsafe (headerName ++ " " ++ functionName)
            (mkName functionName) ty
    in [f]
transform headerName (C.DecDef (C.TypedefGroup (C.DeclSpec _ _ (C.Tenum (Just (C.Id name _)) vals _ _) _) _ _ _) _)
  = let tname = name ++ "T"
        unname = "un" ++ tname
        fnName = "encode" ++ (caps . drop 1 . dropWhile (/= '_') $ name)
        nt = NewtypeD
             [] (mkName tname) []
             (RecC (mkName tname)
               [(mkName unname, NotStrict, ConT (mkName "CUChar"))])
             [mkName "Eq", mkName "Show"]
        da = DataD [] (mkName name) []
             (map (\(C.CEnum (C.Id n _) (Just (C.Const (C.IntConst _ _ _v _) _)) _) ->
               NormalC (mkName n) []) vals)
             [mkName "Eq", mkName "Show"]
        fty = SigD (mkName fnName)
              (AppT (AppT ArrowT (ConT (mkName name))) (ConT (mkName tname)))
        fun = FunD (mkName fnName)
            $ map mkCls vals
        mkCls (C.CEnum (C.Id n _) (Just (C.Const (C.IntConst _ _ v _) _)) _)
            = Clause [ConP (mkName n) []]
              (NormalB (AppE (ConE (mkName tname)) (LitE (IntegerL v))))
              []
    in [nt, da, fty, fun]

transform _ _ = []

foldnconquer :: Type -> [Type] -> Type
foldnconquer = foldr (\x y -> AppT (AppT ArrowT x) y)

paramify :: [C.Param] -> [Type]
paramify = map (\(C.Param _ (C.DeclSpec _ _ ty _) d _) -> tyco' d ty)

tyco' :: C.Decl -> C.TypeSpec -> Type
tyco' (C.Ptr _ d _) x = AppT (ConT (mkName "Ptr")) $ tyco' d x
tyco' _ x = tyco x

tyco :: C.TypeSpec -> Type
tyco (C.Tvoid _)               = ConT $ mkName "()"
tyco (C.Tint _ _)              = ConT $ mkName "CInt" -- TODO: the first arg is if it is signed
tyco (C.Tchar _ _)             = ConT $ mkName "CChar"
tyco (C.Tfloat _)              = ConT $ mkName "CFloat"
tyco (C.Tdouble _)             = ConT $ mkName "CDouble"
tyco (C.Tenum (Just (C.Id s _)) _ _ _)  = ConT $ mkName (s ++ "T")
tyco (C.Tnamed (C.Id "size_t" _) _ _)   = ConT $ mkName "CUInt"
tyco (C.Tnamed (C.Id "blasint" _) _ _)  = ConT $ mkName "CInt"
tyco (C.Tnamed (C.Id "openblas_complex_float" _) _ _)   = ConT $ mkName "(Ptr (Complex Float))"
tyco (C.Tnamed (C.Id "openblas_complex_double" _) _ _)  = ConT $ mkName "(Ptr (Complex Double))"
tyco x = error $ "tyco: unimplemented: " ++ show x

caps (x:xs) = toUpper x : map toLower xs


{-# OPTIONS_GHC -Wno-orphans #-}

module Data.Function.FastMemo.Instances () where

import Data.Complex (Complex)
import Data.Function.FastMemo.Char ()
import Data.Function.FastMemo.Class (Memoizable)
import Data.Function.FastMemo.Int ()
import Data.Functor.Identity (Identity)
import Data.Proxy (Proxy)
import Data.Version (Version)
import Data.Void (Void)

instance Memoizable Bool

instance Memoizable a => Memoizable (Maybe a)

instance (Memoizable a, Memoizable b) => Memoizable (Either a b)

instance Memoizable Void

instance Memoizable ()

instance Memoizable (Proxy a)

instance Memoizable Ordering

instance Memoizable a => Memoizable (Complex a)

instance Memoizable Version

instance Memoizable a => Memoizable (Identity a)

instance (Memoizable a, Memoizable b, Memoizable c) => Memoizable (a, b, c)

instance (Memoizable a, Memoizable b, Memoizable c, Memoizable d) => Memoizable (a, b, c, d)

instance (Memoizable a, Memoizable b, Memoizable c, Memoizable d, Memoizable e) => Memoizable (a, b, c, d, e)

instance (Memoizable a, Memoizable b, Memoizable c, Memoizable d, Memoizable e, Memoizable f) => Memoizable (a, b, c, d, e, f)

instance (Memoizable a, Memoizable b, Memoizable c, Memoizable d, Memoizable e, Memoizable f, Memoizable g) => Memoizable (a, b, c, d, e, f, g)