-- |
-- Module      : BenchShow.Internal.Common
-- Copyright   : (c) 2018 Composewell Technologies
--
-- License     : BSD3
-- Maintainer  : harendra.kumar@gmail.com
-- Stability   : experimental
-- Portability : GHC
--

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}

module BenchShow.Internal.Common
    ( Presentation(..)
    , GroupStyle(..)
    , FieldTick (..)
    , SortColumn (..)
    , RelativeUnit (..)
    , Estimator (..)
    , DiffStrategy (..)
    , TitleAnnotation (..)
    , Config(..)
    , defaultConfig

    , getFieldRange
    , getFieldTick

    , GroupMatrix(..)
    , prepareGroupMatrices

    , ReportColumn(..)
    , RawReport(..)
    , ReportType(..)
    , diffString
    , makeTitle
    , prepareToReport
    , reportComparingGroups
    , reportPerGroup
    ) where

import Control.Applicative (ZipList(..))
import Control.Arrow (second)
import Control.Exception (assert)
import Control.Monad (when, unless)
import Data.Char (toLower)
import Data.Foldable (foldl')
import Data.Function ((&), on)
import Data.List
       (transpose, groupBy, (\\), find, sortBy, elemIndex, intersect,
        intersectBy)
import Data.List.Split (linesBy)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Ord (comparing)
import Debug.Trace (trace)
import Statistics.Types (Estimate(..), ConfInt(..))
import System.Directory (createDirectoryIfMissing)
import System.FilePath ((</>))
import Text.CSV (CSV, parseCSVFromFile)
import Text.Read (readMaybe)

import BenchShow.Internal.Analysis

-------------------------------------------------------------------------------
-- Utilities
-------------------------------------------------------------------------------

filterSanity :: (Eq a, Show a) => String -> [a] -> [a] -> IO ()
filterSanity label old new = do
    let added = new \\ old

    when (null new) $ error $
        label ++ " must select at least one item from the list: "
        ++ show old

    unless (null added) $ error $
        label ++
        " must not add any new items to the original list. The \
        \following items were added: " ++ show added
        ++ "\nOriginal groups: " ++ show old
        ++ "\nNew groups: " ++ show new

-------------------------------------------------------------------------------

data ReportType = TextReport | GraphicalChart

-- | How to show the results for multiple benchmark groups presented in columns
-- or bar chart clusters. In relative comparisons, the first group is
-- considered as the baseline and the subsequent groups are compared against
-- the baseline.
--
-- /Definition changed in 0.3.0/
-- @since 0.2.0
data GroupStyle =
      Absolute    -- ^ Show absolute values of the field for all groups
    | Diff        -- ^ Show baseline group as absolute values and values for
                  -- the subsequent groups as difference from the baseline
    | PercentDiff -- ^ If the value of the group being compared is higher than
                  -- the baseline then display the difference as percentage of
                  -- baseline otherwise display the difference as a percentage
                  -- of the group being compared.
    | Multiples   -- ^ If the value of the group being compared is higher than
                  -- the baseline then display @+(value / baseline value)@
                  -- otherwise display @-(baseline value / value)@. This
                  -- provides a normalized comparison independent of the
                  -- absolute value of a benchmark. Note that 'Multiples' can
                  -- be directly computed using 'PercentDiff' and vice-versa.
    deriving (Eq, Show, Read)

-- | How to present the reports or graphs. Each report presents a number of
-- benchmarks as rows, it may have, (1) a single column presenting the values
-- for a single field, (2) multiple columns presenting values for different
-- fields, or (3) multiple columns presenting values of the same field for
-- different groups.
--
-- @since 0.2.0
data Presentation =
      Solo              -- ^ Reports are generated for each group and for
                        -- each field selected by the configuration. Each
                        -- report presents benchmarks in a single group with a
                        -- single column presenting a single field.  If there
                        -- are @m@ fields and @n@ groups selected by the
                        -- configuration then a total of @m x n@ reports are
                        -- generated.  Output files are named using
                        -- @-estimator-groupname-fieldname@ as suffix.
    | Groups GroupStyle -- ^ One report is generated for each field selected by
                        -- the configuration. Each report presents a field
                        -- with all the groups selected by the configuration as
                        -- columns or clusters. Output files are named using
                        -- @-estimator-fieldname@ as suffix.
    | Fields            -- ^ One report is generated for each group selected by
                        -- the configuration. Each report presents a group
                        -- with all the fields selected by the configuration as
                        -- columns or clusters. Output files are named using
                        -- @-estimator-groupname@ as suffix.
    deriving (Eq, Show, Read)

-- | FieldTick is used only in visual charts to generate the major ticks on
-- the y-axis. You can specify either the size of a tick ('TickSize') or the
-- total number of ticks ('TickCount').
--
-- @since 0.2.0
data FieldTick =
      TickSize Int  -- ^ Size of a tick, the unit is microseconds for time
                     -- fields, and bytes for space fields.
    | TickCount Int -- ^ Total number of ticks in the range spread.

-- | When sorting and filtering the benchmarks using 'selectBenchmarks' we can
-- choose a column as a sort criterion.  'selectBenchmarks' is provided with
-- the data for the corresponding column which can be used for sorting the
-- benchmarks. The column could be a group or a field depending on the
-- 'Presentation'.
--
-- @since 0.2.0
data SortColumn =
      ColumnIndex Int -- ^ Specify the index of the sort column. Index 0
        -- corresponds to the first @value@ column. In a textual report, the
        -- very first column consists of benchmark names, therefore index 0
        -- addresses the second column of the report.
    | ColumnName (Either String (String, Int)) -- ^ Specify the column using
        -- the name of the group or the field it represents, and the @runId@.
        -- When just the name is enough to uniquely identify the sort column
        -- the 'Left' constructor can be used, otherwise the 'Right'
        -- constructor is used which can use the @runId@ to disambiguate.  In a
        -- 'Fields' presentation, just the field name is enough.  In a 'Groups'
        -- presentation, when there is a single benchmark run in the input
        -- file, just the group name is enough to identify the group, the
        -- @runId@ defaults to 0.  However, when there are multiple runs, a
        -- group needs to specify a @runId@ as well.

-- | Strategy to compute the difference between two groups of benchmarks being
-- compared.
--
-- @since 0.2.0
data DiffStrategy =
      SingleEstimator -- ^ Use a single estimator to compute the difference
                      -- between the baseline and the candidate. The estimator
                      -- that is provided in the 'Config' is used.
    | MinEstimator    -- ^ Use 'Mean', 'Median' and 'Regression' estimators for
                      -- both baseline and candidate, and report the estimator
                      -- that shows the minimum difference. This is more robust
                      -- against random variations.
    {-
    | WorstBest
    | BestBest
    -}
    deriving (Show, Read)

-- | Additional annotations that can be optionally added to the title of the
-- report or graph.
--
-- @since 0.2.2
{-# DEPRECATED TitleAnnotation "Please use mkTitle to make a custom title" #-}
data TitleAnnotation = TitleField | TitleEstimator | TitleDiff
    deriving (Eq, Show, Read)

-- | Configuration governing generation of chart. See 'defaultConfig' for the
-- default values of these fields.
--
-- @since 0.2.0
data Config = Config
    {
    -- | Provide more details in the report, especially the standard deviation,
    -- outlier variance, R-square estimate and an annotation to indicate the
    -- actual method used when using 'MinEstimator' are reported.
      verbose :: Bool

    -- | The directory where the output graph or report file should be placed.
    , outputDir   :: Maybe FilePath

    -- | Function to make a title for the report. The argument to the function
    -- is the benchmark field name for which the report is being made.
    , mkTitle  :: Maybe (String -> String)

    -- | /DEPRECATED: Please use 'mkTitle' instead./
    --
    -- Report title, more information like the plotted field name or
    -- the presentation style may be added to it.
    , title  :: Maybe String

    -- | /DEPRECATED: Please use 'mkTitle' instead./
    --
    -- Additional annotations to be added to the title
    , titleAnnotations :: [TitleAnnotation]

    -- | How to determine the layout of the report or the chart.
    , presentation :: Presentation

    -- | The estimator used for the report.
    , estimator    :: Estimator

    -- | The minimum percentage difference between two runs of a benchmark
    -- beyond which the benchmark is flagged to have regressed or improved.
    , threshold :: Word

    -- | Strategy to compare two runs or groups of benchmarks.
    , diffStrategy  :: DiffStrategy

    -- | Omit the baseline group in normalized relative comparisons i.e.
    -- when the 'GroupStyle' is 'PercentDiff' or 'Multiples'.
    , omitBaseline :: Bool

    ---------------------------------------------------------------------------
    -- Fields (Columns)
    ---------------------------------------------------------------------------

    -- | Filter and reorder the benchmarking fields. It is invoked with a list
    -- of all available benchmarking fields. Only those fields present in the
    -- output of this function are plotted and in that order.
    , selectFields :: [String] -> [String]

    -- | The values in the tuple are @(fieldName, RangeMin, RangeMax)@.
    -- Specify the min and max range of benchmarking fields. If the field
    -- value is outside the range it is clipped to the range limit.
    -- For time fields, the range values are in microseconds, and for space
    -- fields they are in bytes. The minimum of the range is used to determine
    -- the unit for the field.
    , fieldRanges :: [(String, Double, Double)]

    -- | The values in the tuple are @(fieldName, tick)@.  Specify the
    -- tick size of the fields to be used for the graphical reports.
    , fieldTicks :: [(String, FieldTick)]

    ---------------------------------------------------------------------------
    -- Groups (Row Grouping)
    ---------------------------------------------------------------------------

    -- | Filter, group and translate benchmark names. This function is invoked
    -- once for all benchmark names found in the results. It produces a tuple
    -- @(groupname, benchname)@, where @groupname@ is the name of the group the
    -- benchmark should be placed in, and @benchname@ is the translated
    -- benchmark name to be used in the report.  If it returns 'Nothing' for a
    -- benchmark, that benchmark is omitted from the results.
    , classifyBenchmark :: String -> Maybe (String, String)

    -- | Filter and reorder the benchmark group names. A benchmark group may be
    -- assigned using 'classifyBenchmark'; when not assigned, all benchmarks
    -- are placed in the @default@ group. The input to this function is a list
    -- of tuples with benchmark group names and the @runId@s.  The output
    -- produced by this function is a filtered and reordered subset of the
    -- input.  Only those benchmark groups present in the output are rendered
    -- and are presented in that order.
    , selectGroups :: [(String, Int)] -> [(String, Int)]

    ---------------------------------------------------------------------------
    -- Benchmarks (Rows)
    ---------------------------------------------------------------------------

    -- | Filter and reorder benchmarks. 'selectBenchmarks' takes a function
    -- argument, the function is invoked with a sorting column name or index
    -- and a 'GroupStyle'. The output of the function is either a 'Right' value
    -- consisting of tuples of the benchmark names and values corresponding to
    -- the given column and style or a 'Left' value indicating an error.
    -- 'selectBenchmarks' can inspect these benchmarks and their values to
    -- produce a filtered and sorted list of benchmark names that are to be
    -- rendered.
    --
    -- The style argument is ignored when the report presentation is not
    -- 'Groups'. When style is 'Nothing', the presentation setting specified in
    -- the configuration is used.
    --
    -- /Signature changed in 0.3.0/
    , selectBenchmarks
        :: (SortColumn -> Maybe GroupStyle -> Either String [(String, Double)])
        -> [String]
    }

-- IMPORTANT: If you change the defaults, please change the defaults in the CLI
-- help as well.
--
-- | Default configuration. Use this as the base configuration and modify the
-- required fields. The defaults are:
--
-- @
--  verbose           = False
--  mkTitle           = Nothing
--  titleAnnotations  = [TitleField]
--  outputDir         = Nothing
--  presentation      = Groups Absolute
--  estimator         = Median
--  threshold         = 3
--  diffStrategy      = SingleEstimator
--  omitBaseline      = False
--  selectFields      = filter (flip elem ["time", "mean", "maxrss"] . map toLower)
--  fieldRanges       = []
--  fieldTicks        = []
--  classifyBenchmark = Just . ("default",)
--  selectGroups      = id
--  selectBenchmarks  = \f -> either error (map fst) $ f (ColumnIndex 0) Nothing
-- @
--
-- @since 0.2.0
defaultConfig :: Config
defaultConfig = Config
    { verbose           = False
    , mkTitle           = Nothing
    , title             = Nothing
    , titleAnnotations  = [TitleField]
    , outputDir         = Nothing
    , presentation      = Groups Absolute
    , estimator         = Median
    , threshold         = 3
    , diffStrategy      = SingleEstimator
    , omitBaseline      = False
    , selectFields      = filter (flip elem ["time", "mean", "maxrss"] . map toLower)
    , fieldRanges       = []
    , fieldTicks        = []
    , classifyBenchmark = Just . ("default",)
    , selectGroups      = id
    , selectBenchmarks  = \f -> either error (map fst) $ f (ColumnIndex 0) Nothing
    }

-------------------------------------------------------------------------------
-- Benchmarking field types
-------------------------------------------------------------------------------

timeFields :: [String]
timeFields = map (map toLower)
    [ "time"
    , "mean"
    , "cpuTime"
    , "utime"
    , "stime"
    , "mutatorWallSeconds"
    , "mutatorCpuSeconds"
    , "gcWallSeconds"
    , "gcCpuSeconds"
    ]

isTimeField :: String -> Bool
isTimeField fieldName = map toLower fieldName `elem` timeFields

allocFields :: [String]
allocFields = map (map toLower) ["allocated", "bytesCopied", "maxrss"]

isAllocationField :: String -> Bool
isAllocationField fieldName = map toLower fieldName `elem` allocFields

predictorFields :: [String]
predictorFields = map (map toLower)
    [ "iters"
    -- , "minflt"
    -- , "majflt"
    -- , "nvcsw"
    -- , "nivcsw"
    ]

isPredictorField :: String -> Bool
isPredictorField fieldName = map toLower fieldName `elem` predictorFields

-------------------------------------------------------------------------------
-- Units
-------------------------------------------------------------------------------

-- | Describe a relative unit i.e. a unit in terms of another unit. A relative
-- unit has a label and a ratio which when multiplied with the unit gives us
-- the other unit. For example, if the known time unit is seconds, we can
-- describe a millisecond as @Unit "ms" (1/1000)@.
data RelativeUnit = RelativeUnit String Double deriving Show

getTimeUnit :: Double -> RelativeUnit
getTimeUnit k
    | k < 0      = getTimeUnit (-k)
    | k >= 1     = RelativeUnit "s" 1
    | k >= 1e-3  = RelativeUnit "ms" 1e-3
    | k >= 1e-6  = RelativeUnit "μs" 1e-6
    | otherwise  = RelativeUnit "ns" 1e-9

getSpaceUnit :: Double -> RelativeUnit
getSpaceUnit k
    | k < 0             = getSpaceUnit (-k)
    | k >= 2^(30 ::Int) = RelativeUnit "GiB" (2^(30 :: Int))
    | k >= 2^(20 ::Int) = RelativeUnit "MiB" (2^(20 :: Int))
    | k >= 2^(10 ::Int) = RelativeUnit "KiB" (2^(10 :: Int))
    | otherwise         = RelativeUnit "Bytes" 1

getUnitByFieldName :: String -> Double -> RelativeUnit
getUnitByFieldName fieldName fieldMin =
    case isTimeField fieldName of
        True -> getTimeUnit fieldMin
        False -> case isAllocationField fieldName of
            True -> getSpaceUnit fieldMin
            False -> RelativeUnit "" 1

-- returns (multiplier, units)
fieldUnits :: String -> Double -> GroupStyle -> RelativeUnit
fieldUnits fieldName fieldMin style =
    case style of
        Multiples   -> RelativeUnit "x" 1
        PercentDiff -> RelativeUnit "%" 1
        _ -> getUnitByFieldName fieldName fieldMin

-------------------------------------------------------------------------------
-- Comparison
-------------------------------------------------------------------------------

absoluteDiff :: Num a => a -> a -> a
absoluteDiff v1 v2 = v2 - v1

percentDiff :: (Fractional a, Num a, Ord a) => a -> a -> a
percentDiff v1 v2 = ((v2 - v1) * 100) / min v1 v2

-- We map a fraction x between 0 and 1 to a negative 1/x for plotting on an
-- equal and opposite scale.
fraction :: (Fractional a, Num a, Ord a, Show a) => a -> a -> a
fraction v1 v2 =
    let val = v2 / v1
    in case val of
            x | x <= 0 -> error $ "BenchShow.Internal.Common.fraction: negative: " ++ show x
            x | x < 1 -> negate (1 / x)
            x | x >= 1 -> x
            x -> error $ "BenchShow.Internal.Common.fraction: unhandled: " ++ show x

cmpTransformColumns :: ReportType
                    -> GroupStyle
                    -> Estimator
                    -> DiffStrategy
                    -- XXX we do not really need the benchmark name here
                    -> [[(String, AnalyzedField)]]
                    -> (Maybe [[Estimator]], [[(String, Double)]])
cmpTransformColumns rtype style estimator diffStrategy cols =
    let cmpWith diff =
            let firstCol = head columns
                colTransform col =
                    let mkDiff (n1, v1) (n2,v2) =
                            verify (n1 == n2) (n2, diff v1 v2)
                    in zipWith mkDiff firstCol col
            in map colTransform (tail columns)

        cmpMinWith diff =
            let firstCol = head cols
                colTransform col = zipWith (mkMinDiff diff) firstCol col
            in map colTransform (tail cols)

        diffWith f =
                case diffStrategy of
                    MinEstimator ->
                        let (ests, vals) = unzip $ map unzip (cmpMinWith f)
                        in ( Just $ map (const estimator) (head cols) : ests
                           , head columns : vals
                           )
                    SingleEstimator ->
                        (Nothing, head columns : cmpWith f)

        relativeDiffWith baseVal f =
            -- In a comparative graphical chart we cannot show the absolute
            -- values in the baseline column as the units won't match for
            -- the baseline and the diff clusters.
            let baseCol =
                    case rtype of
                        TextReport -> head columns
                        GraphicalChart | length columns == 1 ->
                            head columns
                        GraphicalChart ->
                            map (\(n,_) -> (n,baseVal)) (head columns)
            in case diffStrategy of
                MinEstimator ->
                    let (ests, vals) = unzip $ map unzip (cmpMinWith f)
                    in ( Just $ map (const estimator) (head cols) : ests
                       , baseCol : vals
                       )
                SingleEstimator ->
                   (Nothing, baseCol : cmpWith f)
    in case style of
            Absolute    -> diffWith (\_ x -> x)
            Diff        -> diffWith absoluteDiff
            PercentDiff -> relativeDiffWith 100 percentDiff
            Multiples   -> relativeDiffWith 1 fraction
    where
        verify a b = if a then b else error "bug: benchmark names mismatch"
        transformVals = map (map (second (getAnalyzedValue estimator)))
        columns = transformVals cols

        -- Find which estimator gives us the minimum diff
        mkMinDiff diff (n1, v1) (n2,v2) = verify (n1 == n2) $
            let meanDiff = diff (getAnalyzedValue Mean v1)
                                (getAnalyzedValue Mean v2)
                medDiff = diff (getAnalyzedValue Median v1)
                               (getAnalyzedValue Median v2)
                regDiff = diff (getAnalyzedValue Regression v1)
                               (getAnalyzedValue Regression v2)
            in if abs medDiff <= abs meanDiff
               then if abs medDiff <= abs regDiff
                    then (Median, (n2, medDiff))
                    else (Regression, (n2, regDiff))
                else if abs meanDiff <= abs regDiff
                     then (Mean, (n2, meanDiff))
                     else (Regression, (n2, regDiff))

columnNameByStyle :: GroupStyle -> [ReportColumn] -> [ReportColumn]
columnNameByStyle _ [] = []
columnNameByStyle style columns@(h:t) =
    let withDiff name = colSuffix baseName h : map (colSuffix name) t
    in case style of
            Diff        | length columns > 1 -> withDiff diffName
            Multiples   | length columns > 1 -> withDiff fracName
            PercentDiff | length columns > 1 -> withDiff diffName
            _ -> columns

    where
    colSuffix xl col = col { colName = xl (colName col) }
    baseName        = id -- (++ "(base)")
    diffName        = (++ " - " ++ colName h) -- "(-base)")
    fracName        = (++ "/" ++ colName h) -- "/base")

columnNameByUnit :: [RelativeUnit] -> [ReportColumn] -> [ReportColumn]
columnNameByUnit units columns =
    let applyUnit col (RelativeUnit label _) =
            col { colName = colName col ++ inParens label }
    in zipWith applyUnit columns units

-- Represents the data for a single benchmark run
data GroupMatrix = GroupMatrix
    { groupIndex :: Int
    , groupName   :: String
    , groupBenches :: [(String, String)] -- (newname, origname)
    , groupMatrix :: BenchmarkMatrix
    } deriving Show

-- Each run may be split into multiple groups of benchmarks.  Benchmarks can be
-- renamed by the classifier. Sanity checks:
-- Two original benchmarks cannot map to the same target benchmark
--
-- When using a comparative style report, after filtering and sorting:
-- Same original benchmark cannot belong to multiple groups
-- All groups must have exactly the same benchmark names
splitGroup :: (String -> Maybe (String, String))
           -> (Int, BenchmarkMatrix)
           -> [GroupMatrix]
splitGroup classify (serial, matrix@BenchmarkMatrix{..}) =
    let classified = mapMaybe (\x -> fmap (,x) $ classify x) (map fst rowValues)
    in if null classified
       then error "No benchmarks were selected by \"classifyBenchmark\""
       else
          sortBy (comparing (fst . fst)) classified
        & groupBy ((==) `on` (fst . fst))
        & map (foldr foldGroup ("",[]))
        & map sanityCheckGroup
        & map (\(name, benches) ->
            GroupMatrix
            { groupIndex  = serial
            , groupName    = name
            , groupBenches = benches
            , groupMatrix  = matrix
            })

    where

    foldGroup ((grp, bench), srcBench) (_, tuples) =
        (grp, (bench, srcBench) : tuples)

    sanityCheckGroup orig@(grp, tuples) =
        let duplicated =
                  sortBy (comparing fst) tuples
                & groupBy ((==) `on` fst)
                & filter ((>1) . length)
        in if not $ null duplicated
           then
            let msg = unlines (map show duplicated)
            in error $ "Two benchmarks must not map to the same target \
               \benchmark. Please check your 'classifyBenchmark' operation. \
               \In group " ++ show grp ++ ", the following target benchmarks \
               \are mapped to more than one source benchmarks:\n" ++ msg
            else orig

-------------------------------------------------------------------------------
-- sort the benchmark groups
-------------------------------------------------------------------------------

findGroup :: [GroupMatrix] -> (String, Int) -> Maybe GroupMatrix
findGroup matrices (name, i) =
    find (\x -> groupName x == name && groupIndex x == i) matrices

sortGroups :: Config -> [GroupMatrix] -> IO [GroupMatrix]
sortGroups Config{..} matrices = do
    let origGroups = map (\x -> (groupName x, groupIndex x)) matrices
        newGroups = selectGroups origGroups

    filterSanity "selectGroups" origGroups newGroups
    return $ mapMaybe (findGroup matrices) newGroups

-------------------------------------------------------------------------------
-- sort the benchmarks
-------------------------------------------------------------------------------

extractColumn :: String -> GroupMatrix -> [(String, AnalyzedField)]
extractColumn field GroupMatrix{..} =
    let idx = elemIndex field (colNames groupMatrix)
        vals = case idx of
            Just i -> map (!! i) (map snd (rowValues groupMatrix))
            Nothing -> error $ "Field [" ++ field
                ++ "] does not exist in group ["
                ++ groupName ++ "] and run id [" ++ show groupIndex ++ "]"
    in zip (map fst groupBenches) vals

extractColumnValue :: String -> GroupMatrix -> Estimator -> [(String, Double)]
extractColumnValue field matrix estimator =
    map (second (getAnalyzedValue estimator)) $ extractColumn field matrix

benchmarkCompareSanity :: [String] -> GroupMatrix -> [String]
benchmarkCompareSanity benchmarks GroupMatrix{..} = do
    let benches = map fst groupBenches
    let absent = benchmarks \\ benches
    let msg =
            "selectBenchmarks: Group [" ++ groupName ++ "] run id ["
            ++ show groupIndex
            ++ "] does not contain the following selected benchmarks; \
            \ignoring them: " ++ show absent
            ++ "\nAvailable benchmarks in this group are: "
            ++ show benches

    if (null absent)
    then benchmarks
    else trace msg (benchmarks \\ absent)

selectBenchmarksByField :: Config
                        -> [GroupMatrix]
                        -> [[(String, Double)]]
                        -> (GroupStyle -> [[(String, Double)]])
                        -> [String]
selectBenchmarksByField Config{..} matrices columns colsByStyle =
    let bmnames = selectBenchmarks extractGroup
     in foldl benchmarkCompareSanity bmnames matrices

    where

    grpNames =
        let getName x = (groupName x, groupIndex x)
        in map getName matrices

    -- columns are benchmark groups in this case
    extractGroup colSelector style =
            let cols = case style of
                    Nothing -> columns
                    Just s -> colsByStyle s
            in case colSelector of
                ColumnName (Left name) ->
                    let len = length cols
                    in if len <= 1
                       then extractGroup (ColumnName (Right (name, 0))) style
                       else Left $ "selectBenchmarks: there are " ++ show len
                            ++ " runs in the input data, please specify the run \
                            \index [0-" ++ show (len - 1)
                            ++ "] along with the group name."
                ColumnName (Right (name, runId)) ->
                    extractColumnByGroupName name runId style
                ColumnIndex n -> extractColumnByGroupIndex n cols

    -- The benchmark field is constant.  Extract all benchmark values for the
    -- given field and for the given group.
    findColumnIndex mxs (name, runId) =
        let foldFunc res@(idx, found) grp =
                case found of
                    False ->
                        if groupName grp == name && groupIndex grp == runId
                        then (idx, True)
                        else (idx + 1, found)
                    True -> res
        in foldl foldFunc (0, False) mxs

    extractColumnByGroupName name runId style =
            case findColumnIndex matrices (name, runId) of
                (_, False) -> Left $ "Benchmark group name [" ++ name
                            ++ "] and index [" ++ show runId
                            ++ "] not found. Available groups are: "
                            ++ show grpNames
                (i, True) -> extractGroup (ColumnIndex i) style

    extractColumnByGroupIndex idx cols =
        let len = length cols
        in if idx >= len
           then Left $ "Column index must be in the range [0-"
                ++ show (len - 1) ++ "]"
           else Right $ cols !! idx

selectBenchmarksByGroup :: Config -> GroupMatrix -> [String]
selectBenchmarksByGroup Config{..} grp@GroupMatrix{..} =
    -- XXX this is common to ByField and ByGroup
    let bmnames = selectBenchmarks extractField
     in bmnames

    where

    -- columns are benchmark fields in this case
    extractField (ColumnName (Left name)) _ = extractColumnByFieldName name
    extractField (ColumnName (Right (name, _))) _ =
        -- XXX runId does not make sense for fields
        extractColumnByFieldName name
    extractField (ColumnIndex n) _ = extractColumnByFieldIndex n

    -- The benchmark field is constant.  Extract all benchmark values for the
    -- given field and for the given group.
    extractColumnByFieldName name =
        let fields = colNames groupMatrix
        in case elem name fields of
            False -> Left $ "Benchmark field name [" ++ name
                        ++ "] not found in group ["
                        ++ groupName ++ "]. Available fields are: "
                        ++ show fields
            True -> Right $ extractColumnValue name grp estimator

    extractColumnByFieldIndex idx =
        let fields = colNames groupMatrix
            len = length fields
        in if idx >= len
           then Left $ "Column index must be in the range [0-"
                ++ show (len - 1) ++ "]"
           else Right $ extractColumnValue (fields !! idx) grp estimator

type NumberedLines = [(Int, [String])]

sanityCheckCSV :: CSV -> NumberedLines
sanityCheckCSV csvlines | null csvlines = error $ "The input file is empty"
sanityCheckCSV csvlines =
    let headRow = head csvlines
        rowLen = length headRow
    in  if not $ "name" `elem` map (map toLower) headRow
        then error "No 'Name' column found in the CSV header line"
        else
          -- Add line numbers for error reporting
          zip [1..] csvlines
          -- cleanup blank rows
        & filter (\(_,xs) -> xs /= [""])

          -- make sure all lines are of the same size, So that we can transpose
          -- back and forth without losing information.
        & map (\x@(i,xs) ->
               if length xs == rowLen
               then x
               else error $ "Line number " ++ show i
                        ++ " in the input file is not of the same length as\
                            \ the header line"
              )

-- An iteration field indicates that consecutive rows with the same benchmark
-- name have results from different iterations of the same benchmark and the
-- measurement fields have to be scaled per iteration based on the number of
-- iterations in the iteration count field.
--
-- Make sure that "iters" and "name" are the first and second columns
ensureIterField :: ([String], [NumberedLines])  -> ([String], [NumberedLines])
ensureIterField (header, groups) =
    ( "iters" : "name" : filter isNotNameIter header
    , map reorderNameIter groups
    )

    where

    isNotNameIter x =
           map toLower x /= "name"
        && map toLower x /= "iters"

    notNameIters [] = True
    notNameIters (x:_) = isNotNameIter x

    nameNotFound = error "Name field is required in the csv file"

    reorderNameIter csvlines =
          unzip csvlines
        & second (header :)
        & second transpose
        & second reorder
        & second transpose
        & uncurry zip

        where

        reorder xs =
            let findField x = find (\(y:_) -> map toLower y == x)
                iterCol = replicate (length (head xs) - 1) "1"
            in   fromMaybe iterCol (fmap tail $ findField "iters" xs)
               : fromMaybe nameNotFound (fmap tail $ findField "name" xs)
               : map tail (filter notNameIters xs)

-- Only keep those fields that are passed to this function
-- Also, preserve any predictor fields for regression analysis
filterFields :: [String] -> BenchmarkIterMatrix -> BenchmarkIterMatrix
filterFields fieldNames BenchmarkIterMatrix{..} =
    BenchmarkIterMatrix
        { iterPredColNames = ["iters"] ++ filter isPredictorField iterRespColNames
        , iterRespColNames = filter isRequestedField iterRespColNames
        , iterRowValues = transform iterRowValues
        }

    where

    transform :: [(String, [([Double], [Double])])] -> [(String, [([Double], [Double])])]
    transform = map (\(name, tuples) ->
        let (ys, zs) = unzip tuples
            pcols = transpose (map Left iterPredColNames : map (map Right) ys)
            rcols = transpose (map Left iterRespColNames : map (map Right) zs)
            pcols' = pcols ++ filter isPredictor rcols
            rcols' = filter requested rcols
            pcols'' = map (map fromRt) $ tail $ transpose pcols'
            rcols'' = map (map fromRt) $ tail $ transpose rcols'
        in (name, zip pcols'' rcols''))

    fromRt (Right x) = x
    fromRt _ = error "bug"

    isRequestedField = (`elem` fieldNames)

    requested [] = True
    requested (Left x:_) = isRequestedField x
    requested _ = error "bug"

    isPredictor [] = True
    isPredictor (Left x:_) = isPredictorField x
    isPredictor _ = error "bug"

-- Split the file into different runs
-- return the header fields and list of runs without the header
splitRuns :: NumberedLines -> ([String], [NumberedLines])
splitRuns csvlines =
    let header = snd $ head csvlines
        ls = linesBy (\x -> snd x == header) (tail csvlines)
    in (header, ls)

readWithError :: Read a => Int -> String -> (String, String) -> a
readWithError lno typ (fname, fval) =
    case readMaybe fval of
        Nothing -> error $ "Cannot read " ++ show fname
            ++ " field [" ++ show fval ++ "] as "
            ++ typ ++ " type at line number "
            ++ show lno
        Just n -> n

-- An iteration field indicates that consecutive rows with the same benchmark
-- name have results from different iterations of the same benchmark and the
-- measurement fields have to be scaled per iteration based on the number of
-- iterations in the iteration count field.
--
-- If the first column is iteration then fold all iterations and remove the
-- iteration column.
readIterations :: [String] -> NumberedLines -> BenchmarkIterMatrix
readIterations header csvlines =
    let tuples =
            map (parseNumericFields header) csvlines
            -- we now have a list of triples [(iter, name, (fieldName, [Double])]
          & groupBy successiveIters
          & map (foldl' addIters ("",[]))
    in BenchmarkIterMatrix
        { iterPredColNames = ["iters"]
        , iterRespColNames = drop 2 header
        , iterRowValues = tuples
        }

    where

    -- The first column is iters and the second is the name
    -- We zip the header for error reporting
    parseNumericFields hdr (lno, vals) = parseNumericTuples lno $ zip hdr vals

    parseNumericTuples lno (iter:(_,name):xs) =
          (readWithError lno "Int" iter :: Int
          , name
          , map (\x@(n,_) -> (n, readWithError lno "Double" x)) xs
                :: [(String, Double)]
          )
    parseNumericTuples _ _ = error "iters and name fields are needed"

    successiveIters (i1,name1,_) (i2,name2,_) = name2 == name1 && i2 > i1

    addIters (_,siters) (iter,name,vals) =
        (name, ([fromIntegral iter], map snd vals) : siters)

getFieldRange :: String -> Config -> Maybe (Double, Double)
getFieldRange fieldName Config{..} =
    let res = find (\(x, _, _) -> x == fieldName) fieldRanges
    in case res of
        Nothing -> Nothing
        Just (_, x, y) -> Just (x, y)

getFieldTick :: String -> Config -> Maybe FieldTick
getFieldTick fieldName Config{..} =
    fmap snd $ find (\x -> fst x == fieldName) fieldTicks

getReportExtension :: ReportType -> String
getReportExtension rtype =
    case rtype of
        TextReport -> ".txt"
        GraphicalChart -> ".svg"

prepareOutputFile :: FilePath -> ReportType -> FilePath -> Estimator -> String -> FilePath
prepareOutputFile dir rtype file est field =
    let estStr = case est of
            Mean -> "mean"
            Median -> "median"
            Regression -> "coeff"
        path = dir </> (file ++ "-" ++ estStr ++ "-" ++ field
                             ++ getReportExtension rtype)
    in path

prepareToReport :: FilePath -> Config -> IO (CSV, [String])
prepareToReport inputFile Config{..} = do
    case outputDir of
        Nothing -> return ()
        Just dir -> createDirectoryIfMissing True dir
    -- We assume the dataset is not big and therefore take liberties to process
    -- in a non-streaming fashion.
    csvData <- parseCSVFromFile inputFile
    case csvData of
        Left e -> error $ show e
        Right csvlines -> do
            when (null csvlines) $ error $ "The input file ["
                ++ show inputFile ++ "] is empty"
            let allFields = head csvlines
                fields = selectFields allFields
            filterSanity "selectFields" allFields fields
            let filt x = notElem (map toLower x) ["name", "iters"]
            return (csvlines, filter filt fields)

-- Keep only those benchmarks that belong to the group.
filterGroupBenchmarks :: [GroupMatrix] -> IO [GroupMatrix]
filterGroupBenchmarks matrices = return $ map filterMatrix matrices
    where
    filterMatrix matrix =
        -- XXX make sure there are no duplicates
        let m = groupMatrix matrix
            vals = map (\(new,old) ->
                (new, fromMaybe (error "bug") $ lookup old (rowValues m)))
                (groupBenches matrix)
        in matrix {groupMatrix = m {rowValues = vals}}

_filterCommonSubsets :: [BenchmarkIterMatrix] -> [BenchmarkIterMatrix]
_filterCommonSubsets matrices =
    let commonPreds =
            let initPreds = matrixPreds $ head matrices
            in foldl' intersectPreds initPreds (tail matrices)
    in map (isectCommonPreds commonPreds) matrices

    where

    pcols = iterPredColNames $ head matrices

    cmpPred name v1 v2 =
            case map toLower name of
                "iters" -> v1 == v2
                "nivcsw" -> v1 == v2
                _ -> v1 == v2

    isectBench (name1, preds1) (name2, preds2) =
        let isect row1 row2 = all id $ zipWith3 cmpPred pcols row1 row2
        in assert (name1 == name2) $ (name1, intersectBy isect preds1 preds2)

    matrixPreds = map (second (map fst)) . iterRowValues

    intersectPreds preds matrix = zipWith isectBench preds (matrixPreds matrix)

    isectRows (name1, preds1) (name2, xs) =
        let isect row1 = find (\(x,_) -> all id
                                $ zipWith3 cmpPred pcols row1 x) xs
        in assert (name1 == name2) $ (name1, mapMaybe isect preds1)

    isectCommonPreds preds matrix@BenchmarkIterMatrix{..} =
        matrix
            { iterRowValues = zipWith isectRows preds iterRowValues
            }

-- when comparing make sure all groups have same benchmarks and sort the other
-- ones based on the first column so that they are all in the same order.
selectCommon :: [GroupMatrix] -> IO [GroupMatrix]
selectCommon matrices =
    let commonBenches =
            let initBenches = map fst $ groupBenches $ head matrices
            in foldl' intersectBenches initBenches (tail matrices)
    in mapM (isectCommonBenches commonBenches) matrices

    where

    intersectBenches benches matrix =
        intersect benches (map fst $ groupBenches matrix)

    isectCommonBenches benches matrix@GroupMatrix{..} = do
        let absent = map fst groupBenches \\ benches
            msg =
                "Removing benchmarks " ++ show absent
                ++ " from column [" ++ groupName
                ++ "] run id [" ++ show groupIndex ++ "]"
            lookupBench x = lookup x groupBenches
            findBench x = (x, fromMaybe undefined (lookupBench x))
            newBenches = map findBench benches

        unless (null absent) $ putStrLn msg
        return matrix { groupBenches = newBenches }

prepareGroupMatrices :: Config
                     -> FilePath
                     -> CSV
                     -> [String]
                     -> IO (Int, [GroupMatrix])
prepareGroupMatrices cfg@Config{..} inputFile csvlines fields = do
    let res@(_, ls) =
              sanityCheckCSV csvlines
            & splitRuns

    when (null ls) $
        error $ "No benchmark results found in CSV file: " ++ show inputFile

    let checkForData (runId, xs) =
            when (null xs) $
                putStrLn $ "No benchmark results found in the CSV file ["
                        ++ show inputFile
                        ++ "], for runId: "
                        ++ show runId

    mapM_ checkForData (zip [(0 :: Int)..] ls)

    let (hdr, runs) = ensureIterField res

    xs <- sequence $ map (readIterations hdr) runs
            & map (filterFields fields)
            -- & _filterCommonSubsets
            -- & map filterSamples
            & map foldBenchmark

    zip [0..] xs
        & map (splitGroup classifyBenchmark)
        & concat
        & sortGroups cfg
        >>= selectCommon
        >>= filterGroupBenchmarks
        >>= return . (length runs,)

-- XXX display GHC version as well
-- XXX display the OS/arch
-- XXX display compiler/RTS options as well e.g. -threaded and -N
-- This data should be in the measurement data

data ReportColumn = ReportColumn
    { colName   :: String
    , colUnit   :: RelativeUnit
    , colValues :: [Double]
    , colAnalyzed :: [AnalyzedField]
    } deriving Show

data RawReport = RawReport
    { reportOutputFile :: Maybe FilePath
    , reportIdentifier :: String
    , reportRowIds     :: [String]
    , reportColumns    :: [ReportColumn]
    , reportEstimators :: Maybe [[Estimator]]
    } deriving Show

getFieldMin :: Config -> Double -> String -> Double
getFieldMin cfg minval fieldName =
    case getFieldRange fieldName cfg of
        Nothing -> minval
        Just (minr, _) -> minr

scaleAnalyzedField :: RelativeUnit -> AnalyzedField -> AnalyzedField
scaleAnalyzedField (RelativeUnit _ mult) AnalyzedField{..} =
    AnalyzedField
    { analyzedMean = analyzedMean / mult
    , analyzedStdDev = analyzedStdDev / mult

    , analyzedMedian = analyzedMedian / mult
    , analyzedOutliers = analyzedOutliers
    , analyzedOutlierVar = analyzedOutlierVar
    , analyzedKDE = analyzedKDE
    , analyzedRegCoeff = case
        analyzedRegCoeff of
            Nothing -> Nothing
            Just Estimate{..} ->
                let ConfInt{..} = estError
                in Just $ Estimate
                    { estPoint = estPoint / mult
                    , estError = ConfInt
                        { confIntLDX = confIntLDX / mult
                        , confIntUDX = confIntUDX / mult
                        , confIntCL = confIntCL
                        }
                    }
    , analyzedRegRSq = analyzedRegRSq
    }

prepareGroupsReport :: Config
                    -> GroupStyle
                    -> Maybe FilePath
                    -> ReportType
                    -> Int
                    -> String
                    -> [GroupMatrix]
                    -> Maybe RawReport
prepareGroupsReport cfg@Config{..} style outfile rtype runs field matrices =
    -- XXX Determine the unit based the whole range of values across all columns
    let sortValues :: [String] -> [(String, a)] -> [a]
        sortValues bmarks vals =
            map (\name -> fromMaybe (error "bug") (lookup name vals)) bmarks

        unsortedCols = map (extractColumn field) matrices

        (estimators, transformedCols) =
            cmpTransformColumns rtype style estimator diffStrategy unsortedCols
        transformedColsByStyle s = snd $
            cmpTransformColumns rtype s estimator diffStrategy unsortedCols

        benchmarks = selectBenchmarksByField cfg matrices
                            transformedCols transformedColsByStyle
        sortedCols = map (sortValues benchmarks) transformedCols
        origSortedCols = map (sortValues benchmarks) unsortedCols

        mkColUnits :: [RelativeUnit]
        mkColUnits =
            let cols =
                    if style /= Absolute
                    -- if we consider diff values as well here then the
                    -- units will change to potentially very small.
                    then [head sortedCols]
                    else sortedCols
                minVal = getFieldMin cfg (minimum $ concat cols) field
                mkPercentColUnitText =
                    let unit = fieldUnits field minVal Absolute
                        punit = fieldUnits field 1 style -- % unit
                    in unit : replicate (length matrices - 1) punit
                mkPercentColUnitGraph = [fieldUnits field minVal Absolute]
                mkAbsoluteUnit =
                     let unit = fieldUnits field minVal style
                     in replicate (length matrices) unit
            in case (rtype, style) of
                -- In case of percentDiff in TextReport we use absolute
                -- values in the baseline column, so the unit is different.
                (_, Absolute)   -> mkAbsoluteUnit
                (_, Diff)       -> mkAbsoluteUnit
                (TextReport, _) -> mkPercentColUnitText
                (GraphicalChart, _) | length matrices == 1 ->
                    mkPercentColUnitGraph
                (GraphicalChart, _) -> mkAbsoluteUnit

        mkColValues :: [[Double]]
        mkColValues =
            let applyUnit col (RelativeUnit _ multiplier) =
                    map (/multiplier) col
            in zipWith applyUnit sortedCols mkColUnits

        mkColNames :: [String]
        mkColNames =
                let withSuffix x =
                        groupName x ++
                            if runs > 1
                            then "(" ++ show (groupIndex x) ++ ")"
                            else ""
                in map withSuffix matrices

        columns =
            getZipList
                $ (\n u v a ->
                       ReportColumn n u v (map (scaleAnalyzedField u) a))
                    <$> ZipList mkColNames
                    <*> ZipList mkColUnits
                    <*> ZipList mkColValues
                    <*> ZipList origSortedCols

        removeBaseline xs =
            let rel = case style of
                        Absolute -> False
                        Diff -> False
                        PercentDiff -> True
                        Multiples -> True
            in if omitBaseline && rel && length matrices > 1
               then tail xs
               else xs

    in if length benchmarks > 0
       then Just $ RawReport
                { reportOutputFile = outfile
                , reportIdentifier = field
                , reportRowIds     = benchmarks
                , reportColumns    = removeBaseline
                    $ columnNameByUnit mkColUnits
                    $ columnNameByStyle style columns
                , reportEstimators = fmap removeBaseline estimators
                }
       else Nothing

showStatusMessage :: Show a => Config -> String -> Maybe a -> IO ()
showStatusMessage cfg field outfile =
    let atitle = case mkTitle cfg of
                    Just f -> " [" ++ f field ++ "]"
                    Nothing ->
                        " [" ++ makeTitle field (diffString (presentation cfg)
                                 (diffStrategy cfg)) cfg ++ "]"
    in case outfile of
        Just path ->
            putStrLn $ "Creating chart"
                ++ atitle
                ++ " at "
                ++ show path
        Nothing -> return ()

reportComparingGroups
    :: GroupStyle
    -> FilePath
    -> Maybe FilePath
    -> ReportType
    -> Int
    -> Config
    -> (RawReport -> Config -> IO ())
    -> [GroupMatrix]
    -> String
    -> IO ()
reportComparingGroups style dir outputFile rtype runs cfg@Config{..} mkReport matrices field = do
    let outfile = case outputFile of
            Just file -> Just $ prepareOutputFile dir rtype file
                                            estimator field
            Nothing -> Nothing
        mRawReport = prepareGroupsReport cfg style outfile rtype runs field matrices
    -- Don't make report if it is empty
    case mRawReport of
        Just rawReport -> do
            showStatusMessage cfg field outfile
            mkReport rawReport cfg
        Nothing -> return ()

-- Prepare report for a given group, the report would consist of multiple
-- field columns.
prepareFieldsReport :: Config
                 -> Maybe FilePath
                 -> GroupMatrix
                 -> Maybe RawReport
prepareFieldsReport cfg@Config{..} outfile group =
    let mkColNames :: [String]
        mkColNames = colNames $ groupMatrix group

        benchmarks = selectBenchmarksByGroup cfg group

        getBenchValues name =
              fromMaybe (error "bug") $
                lookup name (rowValues $ groupMatrix group)

        sortedCols = transpose $ map getBenchValues benchmarks
        minColValues = map (minimum . map (getAnalyzedValue estimator))
                           sortedCols

        mkColUnits :: [RelativeUnit]
        mkColUnits = map (\(x, v) -> getUnitByFieldName x (getFieldMin cfg v x))
                         (zip mkColNames minColValues)

        mkColValues :: [[Double]]
        mkColValues =
            let scaleCol (RelativeUnit _ multiplier) = map (/ multiplier)
            in  zipWith scaleCol mkColUnits
                    (map (map (getAnalyzedValue estimator)) sortedCols)

        addUnitLabel name (RelativeUnit label _) =
            if label /= []
            then name ++ inParens label
            else name
        withUnits xs = zipWith addUnitLabel xs mkColUnits

        columns = getZipList $ ReportColumn
                <$> ZipList (withUnits mkColNames)
                <*> ZipList mkColUnits
                <*> ZipList mkColValues
                <*> ZipList sortedCols

    in if length benchmarks > 0
       then Just $ RawReport
                { reportOutputFile = outfile
                , reportIdentifier = groupName group
                , reportRowIds     = benchmarks
                , reportColumns    = columns
                , reportEstimators = Nothing
                }
       else Nothing

reportPerGroup
    :: FilePath
    -> Maybe FilePath
    -> ReportType
    -> Config
    -> (RawReport -> Config -> IO ())
    -> GroupMatrix
    -> IO ()
reportPerGroup dir outputFile rtype cfg@Config{..} mkReport group = do
    let outfile = case outputFile of
            Just file -> Just $ prepareOutputFile dir rtype file
                                            estimator (groupName group)
            Nothing -> Nothing
        mRawReport = prepareFieldsReport cfg outfile group
    -- Don't make report if it is empty
    case mRawReport of
        Just rawReport -> do
            showStatusMessage cfg (groupName group) outfile
            mkReport rawReport cfg
        Nothing -> return ()

-------------------------------------------------------------------------------
-- Utility functions
-------------------------------------------------------------------------------

showDiffStrategy :: DiffStrategy -> String
showDiffStrategy s =
    case s of
        SingleEstimator -> ""
        MinEstimator -> "using min estimator"

diffString :: Presentation -> DiffStrategy -> Maybe String
diffString style s =
    case style of
        Groups Diff -> Just $ "Diff from Baseline " ++ showDiffStrategy s
        Groups PercentDiff -> Just $ "Diff % of Lower " ++ showDiffStrategy s
        Groups Multiples -> Just $ "Multiples of Baseline " ++ showDiffStrategy s
        Groups Absolute -> Nothing
        Solo -> Nothing
        Fields -> Nothing

inParens :: String -> String
inParens str = "(" ++ str ++ ")"

showEstimator :: Estimator -> String
showEstimator est =
    case est of
        Mean       -> "Mean"
        Median     -> "Median"
        Regression -> "Regression Coeff."

addAnnotation :: String -> Maybe String -> Config -> TitleAnnotation -> String
addAnnotation field diff Config{..} annot =
      inParens
    $ case annot of
        TitleField -> field
        TitleEstimator -> showEstimator estimator
        TitleDiff -> maybe "" inParens diff

makeTitle :: String -> Maybe String -> Config -> String
makeTitle field diff cfg@Config{..} =
       fromMaybe "" title
       ++ concatMap (addAnnotation field diff cfg) titleAnnotations


--
-- Copyright (c) 2019, ERICSSON AB
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are met:
--
--     * Redistributions of source code must retain the above copyright notice,
--       this list of conditions and the following disclaimer.
--     * Redistributions in binary form must reproduce the above copyright
--       notice, this list of conditions and the following disclaimer in the
--       documentation and/or other materials provided with the distribution.
--     * Neither the name of the ERICSSON AB nor the names of its contributors
--       may be used to endorse or promote products derived from this software
--       without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -Wall -Werror #-}

module Feldspar.Core.Representation
  ( Var(..)
  , VarId(..)
  , TypeF(..)
  , AExpr(..)
  , Info(..)
  , Expr(..)
  , (:->)
  , EqBox(..)
  , Op(..)
  , fvi
  , fviR
  , CBind(..)
  , bvId
  , BindEnv
  , lookupBE
  , extendBE
  , mkLets
  , sharable
  , legalToShare
  , goodToShare
  ) where

import Feldspar.Compiler.Options (Pretty(..))
import Feldspar.Core.NestedTuples (Tuple)
import Feldspar.Core.Types (BoundedInt, Elements, FVal, Length, Index,
                            IntN, IV, MArr, Mut, Par, Size, Type(..),
                            TypeF(..), TypeRep(..))
import Feldspar.Range (Range)

import qualified Data.ByteString.Char8 as B
import Data.Typeable (Typeable, (:~:)(Refl), eqT)
import Data.Hash (Hashable)
import qualified Data.Set as S
import qualified Data.Map.Strict as M

import Data.Bits (Bits, FiniteBits)
import Data.Complex (Complex)
import Data.Ix
import Data.IORef (IORef)

infixr :->
infixl 5 :@
infix 1 :&

-- | Variable identifier
newtype VarId = VarId { varInteger :: Integer }
  deriving (Eq, Ord, Num, Real, Integral, Enum, Ix)

instance Show VarId where
    show (VarId i) = show i

instance Pretty VarId where
  pretty = show

data Var a = Var { varNum :: VarId, varName :: B.ByteString }

instance Eq (Var a) where
  v1 == v2 = varNum v1 == varNum v2

instance Show (Var a) where
  show (Var n _) = "v" ++ show n

-- | Full expressions always have types of the form 'Expr (Full t)' for some 't' to
--   distinguish them from partial applications of operators.
type Full a = a

-- We currently do not use the type constructor :->
type a :-> b = a -> b

-- | The type of information, for instance range information. Currently only size info.
data Info a = Info { infoSize :: Size a }

instance Eq (Size a) => Eq (Info a) where
  Info x == Info y = x == y

instance Show (Size a) => Show (Info a) where
  show (Info x) = show x

-- | Annotated expression, that is, an expression together with extra information,
--   for instance from a program analysis.
data AExpr a where
  (:&) :: TypeF a => {aeInfo :: Info a, aeExpr :: Expr (Full a)} -> AExpr a

deriving instance Eq (AExpr a)

instance Show (AExpr a) where
  show e = showAExpr 0 e ""

showAExpr :: Int -> AExpr a -> String -> String
showAExpr n (i :& (e :: Expr (Full a))) r = '{':inf ++ "} " ++ showExpr n e r
  where inf = show (infoSize i) ++ " : " ++ show (typeRepF :: TypeRep a)

instance Pretty (AExpr a) where
  pretty = show

{- | The main expression type.
     Applications always have an operator at the left end, and are never annotated.

     Note that an operator itself is not a full expression unless its type is of
     the form 'Full t' for some 't'.
-}
data Expr a where
  Sym      :: Typeable a             => Op a -> Expr a
  (:@)     :: Typeable a             => Expr (a -> b) -> AExpr a -> Expr b

instance Show (Expr a) where
  show e = showExpr 0 e ""

showExpr :: Int -> Expr a -> String -> String
showExpr _ (Sym op) r = show op ++ r
showExpr n (f :@ e) r
  = showExpr n f $ "\n" ++ replicate (n + 2) ' ' ++ showAExpr (n + 2) e r

instance Typeable a => Eq (Expr a) where
  Sym op1 == Sym op2 = op1 == op2
  ((f1 :: Expr (a1 -> b1)) :@ e1) == ((f2 :: Expr (a2 -> b2)) :@ e2)
        = case eqT :: Maybe ((a1,b1) :~: (a2,b2)) of
            Nothing -> False
            Just Refl -> f1 == f2 && e1 == e2
  _ == _ = False

-- | A box which makes its contents equal to everything else with the same type
newtype EqBox a = EqBox {unEqBox :: a}

instance Eq (EqBox a) where
  _ == _ = True

instance Show (EqBox a) where
  show _ = "Box"

-- | The main data type for built-in operators as well as let and conditional
--   constructs.
data Op a where
    -- | Array
    Parallel   :: Type a => Op (Length :-> (Index -> a) :-> Full [a])
    Sequential :: (Type a, Type st) =>
                  Op (Length :-> st :-> (Index -> st -> Tuple '[a, st]) :-> Full [a])
    Append     :: Type a => Op ([a] :-> [a] :-> Full [a])
    GetIx      :: Type a => Op ([a] :-> Index :-> Full a)
    SetIx      :: Type a => Op ([a] :-> Index :-> a :-> Full [a])
    GetLength  :: Type a => Op ([a] :-> Full Length)
    SetLength  :: Type a => Op (Length :-> [a] :-> Full [a])

    -- | Binding
    Variable :: Typeable a => Var a -> Op (Full a)
    Lambda  :: Type a => Var a -> Op (b :-> Full (a -> b))
    Let :: Op (a :-> (a -> b) :-> Full b)

    -- | Bits
    BAnd          :: (Bits a, BoundedInt a, Size a ~ Range a) => Op (a :-> a :-> Full a)
    BOr           :: (Bits a, BoundedInt a, Size a ~ Range a) => Op (a :-> a :-> Full a)
    BXor          :: (Bits a, BoundedInt a, Size a ~ Range a) => Op (a :-> a :-> Full a)
    Complement    :: (Bits a, BoundedInt a, Size a ~ Range a) => Op (a :->       Full a)

    Bit           :: (Bits a, BoundedInt a, Size a ~ Range a) => Op (Index :->       Full a)
    SetBit        :: (Bits a, BoundedInt a, Size a ~ Range a) => Op (a :-> Index :-> Full a)
    ClearBit      :: (Bits a, BoundedInt a, Size a ~ Range a) => Op (a :-> Index :-> Full a)
    ComplementBit :: (Bits a, BoundedInt a, Size a ~ Range a) => Op (a :-> Index :-> Full a)
    TestBit       :: (Bits a, BoundedInt a, Size a ~ Range a) => Op (a :-> Index :-> Full Bool)

    ShiftLU       :: (Bits a, BoundedInt a, Size a ~ Range a) => Op (a :-> Index :-> Full a)
    ShiftRU       :: (Bits a, BoundedInt a, Size a ~ Range a) => Op (a :-> Index :-> Full a)
    ShiftL        :: (Bits a, BoundedInt a, Size a ~ Range a) => Op (a :-> IntN  :-> Full a)
    ShiftR        :: (Bits a, BoundedInt a, Size a ~ Range a) => Op (a :-> IntN  :-> Full a)
    RotateLU      :: (Bits a, BoundedInt a, Size a ~ Range a) => Op (a :-> Index :-> Full a)
    RotateRU      :: (Bits a, BoundedInt a, Size a ~ Range a) => Op (a :-> Index :-> Full a)
    RotateL       :: (Bits a, BoundedInt a, Size a ~ Range a) => Op (a :-> IntN  :-> Full a)
    RotateR       :: (Bits a, BoundedInt a, Size a ~ Range a) => Op (a :-> IntN  :-> Full a)
    ReverseBits   :: (Bits a, BoundedInt a, Size a ~ Range a) => Op (a :->           Full a)

    BitScan       :: (Bits a, BoundedInt a, Size a ~ Range a) => Op (a :-> Full Index)
    BitCount      :: (Bits a, BoundedInt a, Size a ~ Range a) => Op (a :-> Full Index)

    -- | Complex
    MkComplex :: RealFloat a => Op (a :-> a :-> Full (Complex a))
    RealPart  :: RealFloat a => Op (Complex a :-> Full a)
    ImagPart  :: RealFloat a => Op (Complex a :-> Full a)
    Conjugate :: RealFloat a => Op (Complex a :-> Full (Complex a))
    MkPolar   :: RealFloat a => Op (a :-> a :-> Full (Complex a))
    Magnitude :: RealFloat a => Op (Complex a :-> Full a)
    Phase     :: RealFloat a => Op (Complex a :-> Full a)
    Cis       :: RealFloat a => Op (a :-> Full (Complex a))

    -- | Condition
    Condition  ::                      Op (Bool :-> a :-> a :-> Full a)

    -- | Conversion
    F2I     :: (Integral a, RealFloat b)                     => Op (b :-> Full a)
    -- Type a required for resultType in SizeProp.hs.
    I2N     :: (Type b, Integral a, Num b, Size a ~ Range a) => Op (a :-> Full b)
    B2I     :: (Type a, Integral a)                          => Op (Bool  :-> Full a)
    Round   :: (Integral a, RealFloat b)                     => Op (b :-> Full a)
    Ceiling :: (Integral a, RealFloat b)                     => Op (b :-> Full a)
    Floor   :: (Integral a, RealFloat b)                     => Op (b :-> Full a)

    -- | Elements
    EMaterialize :: Type a => Op (Length :-> Elements a :-> Full [a])
    EWrite       :: Type a => Op (Index :-> a :-> Full (Elements a))
    ESkip        :: Type a => Op (Full (Elements a))
    EPar         :: Type a => Op (Elements a :-> Elements a :-> Full (Elements a))
    EparFor      :: Type a => Op (Length :-> (Index -> Elements a) :-> Full (Elements a))

    -- | Eq
    Equal     :: Eq a => Op (a :-> a :-> Full Bool)
    NotEqual  :: Eq a => Op (a :-> a :-> Full Bool)

    -- | Error
    Undefined :: Type a => Op (Full a)
    Assert    :: Type a => String -> Op (Bool :-> a :-> Full a)

    -- | FFI
    ForeignImport :: String -> EqBox a -> Op (Full a)

    -- | Floating
    Pi      :: Floating a => Op (Full a)
    Exp     :: Floating a => Op (a :-> Full a)
    Sqrt    :: Floating a => Op (a :-> Full a)
    Log     :: Floating a => Op (a :-> Full a)
    Pow     :: Floating a => Op (a :-> a :-> Full a)
    LogBase :: Floating a => Op (a :-> a :-> Full a)
    Sin     :: Floating a => Op (a :-> Full a)
    Tan     :: Floating a => Op (a :-> Full a)
    Cos     :: Floating a => Op (a :-> Full a)
    Asin    :: Floating a => Op (a :-> Full a)
    Atan    :: Floating a => Op (a :-> Full a)
    Acos    :: Floating a => Op (a :-> Full a)
    Sinh    :: Floating a => Op (a :-> Full a)
    Tanh    :: Floating a => Op (a :-> Full a)
    Cosh    :: Floating a => Op (a :-> Full a)
    Asinh   :: Floating a => Op (a :-> Full a)
    Atanh   :: Floating a => Op (a :-> Full a)
    Acosh   :: Floating a => Op (a :-> Full a)

    -- | Fractional
    DivFrac :: Fractional a => Op (a :-> a :-> Full a)

    -- | Future
    MkFuture :: Type a => Op (a :-> Full (FVal a))
    Await    :: Type a => Op (FVal a :-> Full a)

    -- | Integral
    Quot :: (Bits a, Bounded a, Integral a, Size a ~ Range a) => Op (a :-> a :-> Full a)
    Rem  :: (Bits a, Bounded a, Integral a, Size a ~ Range a) => Op (a :-> a :-> Full a)
    Div  :: (Bits a, Bounded a, Integral a, Size a ~ Range a) => Op (a :-> a :-> Full a)
    Mod  :: (Bits a, Bounded a, Integral a, Size a ~ Range a) => Op (a :-> a :-> Full a)
    IExp :: (Bounded a, Integral a, FiniteBits a, Size a ~ Range a) => Op (a :-> a :-> Full a)

    -- | Literal
    Literal :: (Type a, Hashable a) => a -> Op (Full a)

    -- | Logic
    And :: Op (Bool :-> Bool :-> Full Bool)
    Or  :: Op (Bool :-> Bool :-> Full Bool)
    Not :: Op (Bool :->          Full Bool)

    -- | Loop
    ForLoop   :: Type a => Op (Length :-> a :-> (Index -> a -> a) :-> Full a)
    WhileLoop :: Type a => Op (a :-> (a -> Bool) :-> (a -> a) :-> Full a)

    -- | Mutable
    Run :: Type a => Op (Mut a :-> Full a)

    -- | MutableArray
    NewArr    :: Type a => Op (Length :-> a :-> Full (Mut (MArr a)))
    NewArr_   :: Type a => Op (Length :-> Full (Mut (MArr a)))
    GetArr    :: Type a => Op (MArr a :-> Index :-> Full (Mut a))
    SetArr    :: Op (MArr a :-> Index :-> a :-> Full (Mut ()))
    ArrLength :: Op (MArr a :-> Full (Mut Length))

    -- | MutableToPure
    RunMutableArray :: Type a => Op (Mut (MArr a) :-> Full [a])
    WithArray       :: Type b => Op (MArr a :-> ([a] -> Mut b) :-> Full (Mut b))

    -- | MutableReference
    NewRef :: Type a => Op (a :-> Full (Mut (IORef a)))
    GetRef :: Type a => Op (IORef a :-> Full (Mut a))
    SetRef :: Type a => Op (IORef a :-> a :-> Full (Mut ()))
    ModRef :: Type a => Op (IORef a :-> (a -> a) :-> Full (Mut ()))

    -- | Nested tuples
    Cons  :: Type a => Op (a :-> Tuple b :-> Full (Tuple (a ': b)))
    Nil   ::           Op (Full (Tuple '[]))
    Car   :: Type a => Op (Tuple (a ': b) :-> Full a)
    Cdr   ::           Op (Tuple (a ': b) :-> Full (Tuple b))
    Tup   ::           Op (Tuple a :-> Full (Tuple a))

    -- | NoInline
    NoInline :: Type a => Op (a :-> Full a)

    -- | Num
    Abs  :: (Num a, Num (Size a)) => Op (a :-> Full a)
    Sign :: (Num a, Num (Size a)) => Op (a :-> Full a)
    Add  :: (Num a, Num (Size a)) => Op (a :-> a :-> Full a)
    Sub  :: (Num a, Num (Size a)) => Op (a :-> a :-> Full a)
    Mul  :: (Num a, Num (Size a)) => Op (a :-> a :-> Full a)

    -- | Ord
    LTH :: (Ord a, Ord (Size a)) => Op (a :-> a :-> Full Bool)
    GTH :: (Ord a, Ord (Size a)) => Op (a :-> a :-> Full Bool)
    LTE :: (Ord a, Ord (Size a)) => Op (a :-> a :-> Full Bool)
    GTE :: (Ord a, Ord (Size a)) => Op (a :-> a :-> Full Bool)
    Min :: (Ord a, Ord (Size a)) => Op (a :-> a :-> Full a)
    Max :: (Ord a, Ord (Size a)) => Op (a :-> a :-> Full a)

    -- | Par
    ParRun    :: Type a => Op (Par a :-> Full a)
    ParNew    :: Type a => Op (Full (Par (IV a)))
    ParGet    :: Type a => Op (IV a :-> Full (Par a))
    ParPut    :: Type a => Op (IV a :-> a :-> Full (Par ()))
    ParFork   ::           Op (Par () :-> Full (Par ()))
    ParYield  ::           Op (Full (Par ()))

    -- | RealFloat
    Atan2     :: RealFloat a => Op (a :-> a :-> Full a)

    -- | Save
    Save :: Type a => Op (a :-> Full a)

    -- When are two size prop operators equal?
    -- | SizeProp
    PropSize :: (Type a, Type b) =>
        EqBox (Size a -> Size b) -> Op (a :-> b :-> Full b)

    -- | Switch
    Switch :: Type b => Op (b :-> Full b)

    -- | ConditionM
    ConditionM :: Monad m => Op (Bool :-> m a :-> m a :-> Full (m a))

    -- | LoopM
    While :: (Monad m, Size (m ()) ~ Size ()) => Op (m Bool :-> m a :-> Full (m ()))
    For   :: (Monad m, Size (m ()) ~ Size ()) => Op (Length :-> (Index -> m a) :-> Full (m ()))

    -- | Mutable
    Return :: (Monad m, Size (m a) ~ Size a)         => Op (a    :-> Full (m a))
    Bind   :: (Monad m, Size (m a) ~ Size a)         => Op (m a  :-> (a -> m b) :-> Full (m b))
    Then   :: Monad m                                => Op (m a  :-> m b        :-> Full (m b))
    When   :: Monad m                                => Op (Bool :-> m ()       :-> Full (m ()))

deriving instance Eq (Op a)
deriving instance Show (Op a)

-- | Utility functions

fvi :: AExpr a -> S.Set VarId
fvi (_ :& e) = fviR e

fviR :: Expr a -> S.Set VarId
fviR (Sym (Variable v)) = S.singleton $ varNum v
fviR (Sym (Lambda v) :@ e) = varNum v `S.delete` fvi e
fviR (f :@ e) = fviR f `S.union` fvi e
fviR _ = S.empty

data CBind where
  CBind :: Type a => Var a -> AExpr a -> CBind

instance Eq CBind where
  CBind (v1@Var{} :: Var a) e1 == CBind (v2@Var{} :: Var b) e2
      = case eqT :: Maybe (a :~: b) of
          Nothing -> False
          Just Refl -> v1 == v2 && e1 == e2

instance Show CBind where
  show (CBind v e) = show v ++ " = " ++ show e

bvId :: CBind -> VarId
bvId (CBind v _) = varNum v

mkLets :: ([CBind], AExpr a) -> AExpr a
mkLets (CBind v e1@(Info i1 :& _) : bs, e@(Info i2 :& _))
  = Info i2 :& Sym Let :@ e1 :@ (Info (i1, i2) :& Sym (Lambda v) :@ mkLets (bs, e))
mkLets ([], e) = e

-- | Functions for bind environments
type BindEnv = M.Map VarId CBind

lookupBE :: Typeable a => String -> BindEnv -> Var a -> AExpr a
lookupBE msg bm (v@(Var n _) :: Var a)
               = case M.lookup n bm of
                      Nothing -> error $ msg ++ ": lookupBE does not find variable " ++ show v
                      Just (CBind (Var{} :: Var b) e)
                           -> case eqT :: Maybe (a :~: b) of
                                   Nothing -> error $ msg ++ ": lookupBE finds conflicing types for " ++ show v
                                   Just Refl -> e

extendBE :: BindEnv -> CBind -> BindEnv
extendBE bm b = M.insert (bvId b) b bm

-- | Expressions that can and should be shared
sharable :: AExpr a -> Bool
sharable e = legalToShare e && goodToShare e

-- | Expressions that can be shared without breaking fromCore
legalToShare :: AExpr a -> Bool
legalToShare (_ :& Sym op) = shOp op
legalToShare (_ :& f :@ _)      = shApp f

shApp :: Expr a -> Bool
shApp (f :@ _) = shApp f
shApp (Sym op) = shOp op

shOp :: Op a -> Bool
-- Binding
shOp Variable{} = False
shOp Lambda{}  = False
-- Elements
shOp ESkip     = False
shOp EWrite    = False
shOp EPar      = False
shOp EparFor   = False
-- Monads
shOp Return    = False
shOp Bind      = False
shOp Then      = False
shOp When      = False
-- Monadic arrays
shOp NewArr    = False
shOp NewArr_   = False
shOp GetArr    = False
shOp SetArr    = False
shOp ArrLength = False
-- Monadic loops
shOp For       = False
shOp While     = False
-- MonadRef
shOp NewRef    = False
shOp GetRef    = False
shOp SetRef    = False
shOp ModRef    = False
-- Nested tuples
shOp Cons      = False
shOp Nil       = False
shOp Cdr       = False
-- Everything else
shOp _ = True

-- | Expressions that are expensive enough to be worth sharing
goodToShare :: AExpr a -> Bool
goodToShare (_ :& Sym (Literal (l :: a))) = largeLit (typeRep :: TypeRep a) l
-- The case below avoids constructing a let-binding for an array stored
-- in a tuple. This is beneficial because the select operator is order
-- of magnitudes cheaper than the array copy generated for the let-binding.
-- With a better compilation of array assignments, the need for this
-- special case goes away.
goodToShare (_ :& Sym Car :@ _ :: AExpr a)
  | ArrayType{} <- typeRepF :: TypeRep a
  = False
goodToShare (_ :& _ :@ _) = True
goodToShare _                   = False

largeLit :: TypeRep a -> a -> Bool
largeLit UnitType       _ = False
largeLit BoolType       _ = False
largeLit IntType{}      _ = False
largeLit FloatType      _ = False
largeLit DoubleType     _ = False
largeLit ArrayType{}    l = not $ null l
largeLit ElementsType{} _ = False
largeLit _              _ = True


{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE QuasiQuotes           #-}
module Enecuum.Samples.Assets.Nodes.Client
  ( clientNode
  , ClientNode(..)
  , NodeConfig (..)
  , SendTo(..)
  , Protocol(..)
  ) where

import qualified Data.Aeson                               as J
import           Data.Aeson.Extra                         (noLensPrefix)
import           Data.Complex
import qualified Data.Map                                 as Map
import           Data.Set                                 (union, (\\))
import qualified Data.Set                                 as Set
import           Data.Text                                hiding (filter, map)
import           Enecuum.Config
import qualified Enecuum.Domain                           as D
import           Enecuum.Framework.Domain.Error
import qualified Enecuum.Framework.Lens                   as Lens
import qualified Enecuum.Language                         as L
import           Enecuum.Prelude                          hiding (unpack)
import           Enecuum.Samples.Assets.Blockchain.Keys
import qualified Enecuum.Samples.Assets.Blockchain.Wallet as A
import qualified Enecuum.Samples.Assets.Nodes.Address     as A
import qualified Enecuum.Samples.Assets.Nodes.Messages    as M
import qualified Enecuum.Samples.Blockchain.Domain        as D
import qualified Enecuum.Samples.Blockchain.Language      as L
import           System.Console.Haskeline
import           Text.Regex.Posix                         ((=~))

data ClientNode = ClientNode
    deriving (Show, Generic)

data instance NodeConfig ClientNode = ClientNodeConfig
    { _dummyOption :: Int
    }
    deriving (Show, Generic)

instance Node ClientNode where
    data NodeScenario ClientNode = CLI
        deriving (Show, Generic)
    getNodeScript CLI = clientNode'
    getNodeTag _ = ClientNode

instance ToJSON   ClientNode                where toJSON    = J.genericToJSON    nodeConfigJsonOptions
instance FromJSON ClientNode                where parseJSON = J.genericParseJSON nodeConfigJsonOptions
instance ToJSON   (NodeConfig ClientNode)   where toJSON    = J.genericToJSON    nodeConfigJsonOptions
instance FromJSON (NodeConfig ClientNode)   where parseJSON = J.genericParseJSON nodeConfigJsonOptions
instance ToJSON   (NodeScenario ClientNode) where toJSON    = J.genericToJSON    nodeConfigJsonOptions
instance FromJSON (NodeScenario ClientNode) where parseJSON = J.genericParseJSON nodeConfigJsonOptions

type TimeGap = Int

data CreateTransaction              = CreateTransaction CLITransaction D.Address deriving (Show, Eq, Ord, Read)
newtype GetLastKBlock               = GetLastKBlock D.Address deriving Read
data GetWalletBalance               = GetWalletBalance Int D.Address deriving Read
newtype GetLengthOfChain            = GetLengthOfChain D.Address deriving Read
newtype StartForeverChainGeneration = StartForeverChainGeneration D.Address deriving Read
data Ping                           = Ping Protocol D.Address deriving Read
newtype StopRequest                 = StopRequest D.Address deriving Read
data GetBlock                       = GetBlock D.StringHash D.Address deriving Read
data Protocol                       = UDP | TCP | RPC deriving (Show, Eq, Ord, Read)
data SendTo                         = SendTo Address D.PortNumber deriving Read
data Address                        = Address D.Host D.PortNumber deriving Read

data GenerateBlocksPacket           = GenerateBlocksPacket
    { blocks  :: D.BlockNumber
    , timeGap :: TimeGap
    , address :: D.Address
    }
    deriving (Show, Read)

data DumpToDB = DumpToDB
    { address :: D.Address
    }
    deriving (Show, Read)

data RestoreFromDB = RestoreFromDB
    { address :: D.Address
    }
    deriving (Show, Read)

data CLITransaction = CLITransaction
  { _owner    :: String
  , _receiver :: String
  , _amount   :: D.Amount
  , _currency :: D.Currency
  } deriving (Show, Eq, Ord, Read)

sendSuccessRequest :: forall a. (ToJSON a, Typeable a) => D.Address -> a -> L.NodeL Text
sendSuccessRequest address request = do
    res :: Either Text D.SuccessMsg <- L.makeRpcRequest address request
    pure . eitherToText $ res

startForeverChainGenerationHandler :: StartForeverChainGeneration -> L.NodeL Text
startForeverChainGenerationHandler (StartForeverChainGeneration address) = sendSuccessRequest address M.ForeverChainGeneration

generateBlocksPacketHandler :: GenerateBlocksPacket -> L.NodeL Text
generateBlocksPacketHandler (GenerateBlocksPacket i timeGap address) = sendSuccessRequest address $ M.NBlockPacketGeneration i timeGap

getLastKBlockHandler :: GetLastKBlock -> L.NodeL Text
getLastKBlockHandler (GetLastKBlock address) = do
    res :: Either Text D.KBlock <- L.makeRpcRequest address M.GetLastKBlock
    pure . eitherToText $ res

idToKey :: (L.FileSystem m, Monad m) => Int -> m (D.PublicKey, String)
idToKey n = do
    let walletsMap = Map.fromList $ fmap (\w -> (A._id (w :: A.CLIWallet), w))  A.hardcodedWalletsWithNames
    case Map.lookup n walletsMap of
        Nothing -> error $ "There is no wallet with id: " +| n |+ ""
        Just j  -> pure (A._publicKey (j :: A.CLIWallet), A._name (j :: A.CLIWallet))

getWalletBalance :: GetWalletBalance -> L.NodeL Text
getWalletBalance (GetWalletBalance walletId address) = do
    (pubKey, name) <- idToKey walletId
    res :: Either Text M.WalletBalanceMsg <- L.makeRpcRequest address (M.GetWalletBalance pubKey)
    let fun :: M.WalletBalanceMsg -> Text
        fun (M.WalletBalanceMsg _ balance) = "" +|| name ||+ " : " +|| balance ||+ ""
    pure $ eitherToText2 $ fmap fun res

transform :: (L.ERandom m, L.Logger m, L.FileSystem m, Monad m) => CLITransaction -> m D.Transaction
transform tx = do
    let walletsMap = Map.fromList $ fmap (\w -> (A._name (w :: A.CLIWallet), w))  A.hardcodedWalletsWithNames
    let ownerName  = _owner tx
    let receiverName = _receiver tx
    let mbOwner = Map.lookup ownerName walletsMap
    let mbReceiver = Map.lookup receiverName walletsMap

    let (ownerPub, ownerPriv) = case mbOwner of
                    Nothing -> error $ "There is no record for owner: " +|| ownerName ||+ "."
                    Just  j -> (pub, priv)
                                where pub = A._publicKey (j :: A.CLIWallet)
                                      priv = fromJust $ A._privateKey (j :: A.CLIWallet)
        receiverPub = case mbReceiver of
                        Nothing -> read receiverName :: D.PublicKey
                        Just j  -> A._publicKey (j :: A.CLIWallet)
    uuid <- L.nextUUID
    D.signTransaction ownerPub ownerPriv receiverPub (_amount tx) (_currency tx) uuid

createTransaction :: CreateTransaction -> L.NodeL Text
createTransaction (CreateTransaction tx address) = do
    transaction <- transform tx
    res :: Either Text D.SuccessMsg <- L.makeRpcRequest address (M.CreateTransaction transaction)
    pure . eitherToText $ res

dumpToDB :: DumpToDB -> L.NodeL Text
dumpToDB (DumpToDB address) = do
    res :: Either Text D.SuccessMsg <- L.makeRpcRequest address M.DumpToDB
    pure . eitherToText $ res

restoreFromDB :: RestoreFromDB -> L.NodeL Text
restoreFromDB (RestoreFromDB address) = do
    res :: Either Text D.SuccessMsg <- L.makeRpcRequest address M.RestoreFromDB
    pure . eitherToText $ res

getLengthOfChain :: GetLengthOfChain -> L.NodeL Text
getLengthOfChain (GetLengthOfChain address) = do
    mKBlock <- L.makeRpcRequest address M.GetLastKBlock
    pure $ case mKBlock of
        Right kBlock       -> "Length of chain is " <> show (D._number kBlock)
        Left  requestError -> requestError

ping :: Ping -> L.NodeL Text
ping (Ping TCP address) = do
    ok <- L.withConnection D.Tcp address $ \conn -> L.send conn D.Ping
    pure $ case ok of
        Just (Right _) -> "Tcp port is available."
        Just (Left  _) -> "Tcp disconnection."
        _              -> "Tcp port is not available."

ping (Ping RPC address) = do
    res :: Either Text D.Pong <- L.makeRpcRequest address D.Ping
    pure $ case res of Right _ -> "Rpc port is available."; Left _ -> "Rpc port is not available."

ping (Ping UDP _) = pure "This functionality is not supported."

stopRequest :: StopRequest -> L.NodeL Text
stopRequest (StopRequest address) = sendSuccessRequest address D.Stop

getBlock :: GetBlock -> L.NodeL Text
getBlock (GetBlock hash address) = do
    mblock <- L.makeRpcRequest address (M.GetGraphNode hash)
    pure $ case mblock of
        Right (D.KBlockContent block) -> "Key block is "  <> show block
        Right (D.MBlockContent block) -> "Microblock is " <> show block
        Left  requestError            -> "Error: "        <> requestError

createNodeId :: M.CreateNodeId -> L.NodeL Text
createNodeId (M.CreateNodeId password) = do
    createKeyPair NodeId $ User (Manual password)
    pure "Success"

createWallet :: M.CreateWallet -> L.NodeL Text
createWallet (M.CreateWallet password) = do
    createWallet' "default" $ User (Manual password)
    pure "Success"

createWalletWithAlias :: M.CreateWalletWithAlias -> L.NodeL Text
createWalletWithAlias (M.CreateWalletWithAlias alias (M.CreateWallet password)) = do
    createWallet' alias $ User (Manual password)
    pure "Success"

showMyWallets :: M.ShowMyWallets -> L.NodeL Text
showMyWallets _ = showWallets

-- TODO change it to console help
help :: Help -> L.NodeL Text
help Help = pure "TODO change it to console help"
{- Commands for client:
CreateNodeId  'Password'
CreateWallet  'Password'
ShowMyWallets
CreateWalletWithAlias "alias" (CreateWallet "Password")
-}

-- For CLI completion
completeWith :: [L.CLICommand] -> String -> [Completion]
completeWith possibles left = case filter (=~ left) possibles of
  []  -> []
  [x] -> [Completion x x False]
  xs  -> map (\str -> Completion left str False) xs

-- local activity
data Help = Help deriving (Show, Read)
data CmdLocal = CreateNodeId | CreateWallet | CreateWalletWithAlias | ShowMyWallets deriving (Show, Enum, Bounded)
cliCommandsLocal = fmap show localCmds
    where localCmds = [minBound..maxBound] :: [CmdLocal]

cliCommands = "Help" : cliCommandsLocal

clientNode :: L.NodeDefinitionL ()
clientNode = clientNode' (ClientNodeConfig 42)

clientNode' :: NodeConfig ClientNode -> L.NodeDefinitionL ()
clientNode' _ = do
    L.logInfo "Client started"
    L.setNodeTag "Client"
    stateVar <- L.newVarIO D.NodeActing

    L.stdF (completeWith cliCommands) $ do
        -- network
        L.stdHandler ping
        L.stdHandler stopRequest
        L.stdHandler $ L.stopNodeHandler' stateVar

        -- local activity
        L.stdHandler createNodeId
        L.stdHandler createWallet
        L.stdHandler createWalletWithAlias
        L.stdHandler showMyWallets
        L.stdHandler help

        -- interaction with graph node
        L.stdHandler createTransaction
        L.stdHandler getWalletBalance
        L.stdHandler dumpToDB
        L.stdHandler restoreFromDB
        -- interaction with graph node sync scenario
        L.stdHandler getLastKBlockHandler
        L.stdHandler getLengthOfChain
        L.stdHandler getBlock

        -- interaction with pow node
        L.stdHandler startForeverChainGenerationHandler

        --  GenerateBlocksPacket {blocks = 2, timeGap = 0, address = Address {_host = "127.0.0.1", _port = 6020}}
        L.stdHandler generateBlocksPacketHandler

    L.awaitNodeFinished' stateVar


-- | Recursive-descent r7rs Scheme parser, built on top of Alex
-- and an incremental stream architecture.
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
module Parser.Parser (readDatum, parseDatum, parseDatumSeq) where

import Control.Monad.Trans (lift)
import Control.Monad.ST.Trans
import Data.Complex (Complex(..))
import Data.Ratio (numerator, denominator, (%))
import Text.Parsec as P hiding (runParser, token, tokenPrim, eof)
import Text.Parsec.Error

import Val
import EvaluationMonad (panic)
import Parser.Monad hiding (token)
import Parser.Lexer

-- Unfortunately, we have to define the parts of the monad that go on top
-- of Alex here, and not in Monad.hs. We could get /most/ of the way there
-- by reorganizing tokens and lexemes, but we can't move 'alexMonadScan'
-- there because it requires things defined in Lexer.hs.
-- I guess in an ideal world, we'd define all this stuff in Monad.hs and
-- get it to compile with a Lexer.hs-boot file.

-- | A lazily-constructed, cached, incremental 'Lexeme' stream type.
-- Haskell's own laziness cannot (obviously, perhaps there is a way)
-- be used to construct a stream of 'Lexeme's because we do not know when
-- the stream will end until the parser decides that it is done parsing.
newtype S s = S (STRef s (Maybe (Maybe (Lexeme, S s))))

unconsS :: S s -> M s (Maybe (Lexeme, S s))
unconsS (S ref) = do
  cache <- readSTRef ref
  case cache of
    Just res -> return res
    Nothing -> do
      lx <- lift alexMonadScan
      restS <- S <$> newSTRef Nothing
      -- this will put a literal TokEOF in the stream at the end.
      let res = Just (lx, restS)
      writeSTRef ref $ Just res
      return res

instance Stream (S s) (M s) Lexeme where
  uncons = unconsS

-- | The monad underlying ParsecT.
type M s = STT s Alex

-- | The parsec parsing monad.
type Parser s = ParsecT (S s) () (M s)

-- | Run a parser, given a label and an input port. The output is:
-- Left (message, first-token-was-eof?)
-- Right parsed-value
runParser :: (forall s. Parser s a) -> String -> Port -> Either (String, Bool) a
runParser p label inputPort
  = case runAlex' alex label inputPort of
    Right (Left (parseError, b)) -> Left (show parseError, b)
    Right (Right v) -> Right v
    Left lexError -> Left (lexError, False)
  where
    alex = runSTT $ do
      initialS <- S <$> newSTRef Nothing
      let parse = runParserT p () label initialS
      firstUncons <- unconsS initialS
      case firstUncons of
        Just (L _ TokEOF, _) -> mapLeft (,True)  <$> parse
        _other               -> mapLeft (,False) <$> parse

runParser_ :: (forall s. Parser s a) -> String -> Port -> Either String a
runParser_ p lbl port = mapLeft fst $ runParser p lbl port

mapLeft :: (e1 -> e2) -> Either e1 b -> Either e2 b
mapLeft f (Left  x) = Left (f x)
mapLeft _ (Right x) = Right x

liftAlex :: Alex a -> Parser s a
liftAlex = lift . lift

-- ----------------------------------------------------------------------------
-- Entrypoints

-- | Read the next datum parseable from the given port.
readDatum :: String -> Port -> Either (String, Bool) Val
readDatum = runParser datum

-- | Parse an input port that contains exactly one datum.
parseDatum :: String -> Port -> Either String Val
parseDatum = runParser_ $ datum <* eof

parseDatumSeq :: String -> Port -> Either String [Val]
parseDatumSeq = runParser_ $ datumSeq <* eof
  -- enforce that we reach the end of the stream, since we only
  -- use this entrypoint to parse whole source files.

-- ----------------------------------------------------------------------------
-- Token parsers

-- | this is like 'Text.Parsec.Prim.tokenPrim', except that 'posFromTok' should
-- give the position of the _matched_ token, not the next one. We need
-- something like this because we absolutely cannot allow a lookahead token.
-- This has the side effect of leaving Parsec's internally stored position
-- on the previously-lexed token, instead of the start of the next one like
-- parsec is expecting. This is /more reasonable/ behavior, at least in our
-- case, and results in better error messages in 'validateByte'.
--
-- The previous 'SourcePos' is available to the position-extraction function
-- so that it can build a 'SourcePos' with parsec's 'setXXX' functions, since
-- the constructor is not exposed. It's unlikely that you'll actually need to
-- use the previous 'SourcePos' in a meaningful way.
tokenPrim :: Stream s m t
          => (t -> String) -> (SourcePos -> t -> SourcePos) -> (t -> Maybe a)
          -> ParsecT s u m a
tokenPrim showTok posFromTok test = mkPT $
  \(State input pos usr) -> do
    r <- uncons input
    pure $ case r of
      Nothing -> Empty $ pure $ P.Error $ unexpectError "" pos
      Just (c,rest) -> let newpos = posFromTok pos c
                       in case test c of
        Nothing -> Empty $ pure $ P.Error $ unexpectError (showTok c) newpos
        Just x -> let newState = State rest newpos usr
                  in newpos `seq` newState `seq`
                     Consumed $ pure $ Ok x newState (newErrorUnknown newpos)
  where
    unexpectError msg pos = newErrorMessage (SysUnExpect msg) pos

token :: (Token -> Maybe a) -> Parser s a
token match = tokenPrim displayLexeme movePos match'
  where
    movePos oldPos (L (AlexPn _addr line col) _)
      = setSourceColumn (setSourceLine oldPos line) col

    match' (L _ tok) = match tok

tokenWithPos :: (Token -> Maybe a) -> Parser s (a, AlexPosn)
tokenWithPos match = tokenPrim displayLexeme movePos match'
  where
    movePos oldPos (L (AlexPn _addr line col) _)
      = setSourceColumn (setSourceLine oldPos line) col

    match' (L pos tok) = (,pos) <$> match tok

displayLexeme :: Lexeme -> String
displayLexeme (L _ t) = "'" ++ show t ++ "'"

eof :: Parser s ()
eof = token $ \case
  TokEOF -> Just ()
  _other -> Nothing

simpleDatum :: Parser s Val
simpleDatum = token $ \case
  TokSymbol sym -> Just $ Symbol $ pack sym
  TokNumber num -> Just $ mkNumber num
  TokBool b     -> Just $ Bool b
  TokChar c     -> Just $ Char c
  TokString str -> Just $ IString $ pack str
  _other        -> Nothing

bracketed :: Parser s a -> Parser s a
bracketed inside = do
  rightBracket <- leftBracket
  r <- inside
  rightBracket
  return r
  where
    leftBracket = token $ \case
      TokLParen -> mkRight $ \case
        TokRParen -> Just ()
        _other    -> Nothing
      TokLBracket -> mkRight $ \case
        TokRBracket -> Just ()
        _other      -> Nothing
      TokLBrace -> mkRight $ \case
        TokRBrace -> Just ()
        _other    -> Nothing
      _other -> Nothing
    mkRight = return . token

sugarToken :: Parser s Token
sugarToken = token $ \case
  TokQuote -> Just TokQuote
  TokComma -> Just TokComma
  TokCommaAt -> Just TokCommaAt
  TokBackquote -> Just TokBackquote
  TokHashQuote -> Just TokHashQuote
  TokHashBackquote -> Just TokHashBackquote
  TokHashComma -> Just TokHashComma
  TokHashCommaAt -> Just TokHashCommaAt
  _other -> Nothing

dot :: Parser s ()
dot = token $ \case
  TokDot -> Just ()
  _other -> Nothing

datumCommentStart :: Parser s ()
datumCommentStart = do
  token $ \case
    TokDatumComment -> Just ()
    _other -> Nothing
  liftAlex enterDatumComment

datumCommentEnd :: Parser s ()
datumCommentEnd = liftAlex exitDatumComment

startVector :: Parser s ()
startVector = token $ \case
  TokLVector -> Just ()
  _other -> Nothing

startByteVector :: Parser s ()
startByteVector = token $ \case
  TokLByteVector -> Just ()
  _other -> Nothing

startLabelDef :: Parser s Int
startLabelDef = do
  (lbl, pos) <- tokenWithPos $ \case
    TokLabelDef lbl -> Just lbl
    _other -> Nothing
  liftAlex $ startDef pos lbl
  return lbl

labelReference :: Parser s Val
labelReference = do
  lbl <- token $ \case
    TokLabelRef lbl -> Just lbl
    _other -> Nothing
  liftAlex $ lookupLabel lbl

-- | Parses a label reference, but additionally ensures
-- that the parser's internal 'defining_label' field does
-- not match the parsed label. If it does, raises an error
-- (at the Alex level).
safeLabelReference :: Parser s Val
safeLabelReference = do
  lbl <- token $ \case
    TokLabelRef lbl -> Just lbl
    _other -> Nothing
  liftAlex $ testRef lbl >> lookupLabel lbl

-- ----------------------------------------------------------------------------
-- Core parser

-- trying to be a little bit more aggressive about having a simple grammar
-- with parsec, since we don't have to satisfy shift/reduce conflicts.
-- We still have to stratify label definitions, to check well-definedness.

datum :: Parser s Val
datum = simpleDatum
        <|> compoundDatum
        <|> definedDatum
        <|> labelReference
        <|> (datumComment >> datum)
        <?> "datum"

-- This parser is not (fully) incremental. It will give up on EOF,
-- of course, but if the input stream contains only some data
-- followed by non-data text, it will try to read one "token"
-- out of the non-data text before returning. This is unavoidable,
-- otherwise it can't know when to quit.
datumSeq :: Parser s [Val]
datumSeq = many datum

datumComment :: Parser s ()
datumComment = do
  datumCommentStart
  _ <- datum
  datumCommentEnd

compoundDatum :: Parser s Val
compoundDatum = (prefixSugar <$> sugarToken <*> datum)
                <|> list
                <|> vector

list :: Parser s Val
list = labeled "list" $ bracketed listContents

listContents :: Parser s Val
listContents = do
  prefix <- many datum
  maybeDot <- optionMaybe $ dot >> datum
  case maybeDot of
    Nothing -> return $ makeImmutableList prefix
    Just d  -> return $ makeImproperImmutableList prefix d

vector :: Parser s Val
vector = normalVector <|> byteVector

normalVector :: Parser s Val
normalVector = labeled "vector" $ do
  startVector
  contents <- many datum
  closeParen
  return $ makeVector contents

byteVector :: Parser s Val
byteVector = labeled "bytevector" $ do
  startByteVector
  bytes <- many byte
  closeParen
  return $ makeByteVector bytes

closeParen :: Parser s ()
closeParen = token $ \case
  TokRParen -> Just ()
  _other -> Nothing

byte :: Parser s Byte
byte = labeled "byte" $ do
  (num, pos) <- tokenWithPos $ \case
    TokNumber n -> Just n
    _other -> Nothing
  validateByte pos num

definedDatum :: Parser s Val
definedDatum = do
  lbl <- startLabelDef
  _ <- fail $ "At the moment, cyclic references will hang, so Thcheme"
              ++ " refuses all label definitions."
  val <- defDatum
  liftAlex $ do
    endDef
    unlessDatumComment $ defineLabel lbl val
    return val

defDatum :: Parser s Val
defDatum = simpleDatum
           <|> safeLabelReference
           <|> (prefixSugar <$> sugarToken <*> datum)
           <|> vector
           <|> defList

-- | like 'list', but if the list contains only a dot, and that
-- dot is a reference to a label that is defined as the list itself,
-- then raises an error as the label is ill-defined.
defList :: Parser s Val
-- Note 'listContents -> . d' is a production of the grammar, but it
-- doesn't matter as long as we test for that case first.
defList = labeled "list" $ bracketed $ (dot >> defDatum) <|> listContents

-- ----------------------------------------------------------------------------
-- Utilities for constructing/validating Vals

labeled :: String -> Parser s a -> Parser s a
labeled = flip label

mkNumber :: Numeric -> Val
mkNumber (LitInteger i)  = Number $ Real $ Bignum i
mkNumber (LitRational r) = Number $ Real $ Ratnum r
mkNumber (LitFloating f) = Number $ Real $ Flonum f
mkNumber (LitComplex l r) = Number $ Complex $
  numericToNumber l :+ numericToNumber r

numericToNumber :: Numeric -> RealNumber
numericToNumber (LitInteger i)  = Bignum i
numericToNumber (LitRational r) = Ratnum r
numericToNumber (LitFloating f) = Flonum f
numericToNumber LitComplex{} = panic "numericToNumber: nested complex"

prefixSugar :: Token -> Val -> Val
prefixSugar tok v = makeImmutableList [Symbol (desugar tok), v]
  where
    desugar TokQuote         = "quote"
    desugar TokBackquote     = "quasiquote"
    desugar TokComma         = "unquote"
    desugar TokCommaAt       = "unquote-splicing"
    desugar TokHashQuote     = "syntax"
    desugar TokHashBackquote = "quasisyntax"
    desugar TokHashComma     = "unsyntax"
    desugar TokHashCommaAt   = "unsyntax-splicing"
    desugar _ = panic "desugar: not a sugar token!"

validateByte :: AlexPosn -> Numeric -> Parser s Byte
validateByte p n = case n of
  LitInteger i -> checkSize i
  LitRational r
    | denominator r == 1 -> checkSize $ numerator r
    | otherwise -> boom
  LitComplex real imag -> do checkExactZero imag
                             validateByte p real
  _other -> boom
  where
    checkSize :: Integer -> Parser s Byte
    checkSize i
      | i >= 0 && i <= 255 = return $ fromInteger i
      | otherwise = boom

    checkExactZero :: Numeric -> Parser s ()
    checkExactZero (LitInteger 0) = pure ()
    checkExactZero (LitRational r)
      | r == 0 % 1 = pure ()
      | otherwise = boom
    checkExactZero _ = boom

    boom :: Parser s a
    boom = fail $ show n ++ " is not an exact byte value"