-- |
-- Module: Staversion.Internal.Format
-- Description: formatting Result output.
-- Maintainer: Toshio Ito <debug.ito@gmail.com>
--
-- __This is an internal module. End-users should not use it.__
module Staversion.Internal.Format
       ( formatAggregatedResults,
         FormatConfig(..),
         FormatVersion,
         formatVersionCabal,
         formatVersionCabalCaret
       ) where

import Data.Foldable (fold)
import Data.Function (on)
import Data.List (intersperse)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NL
import Data.Maybe (fromJust)
import Data.Monoid (mempty, mconcat, (<>))
import Data.Text (Text, pack)
import qualified Data.Text as Text
import qualified Data.Text.Lazy as TL
import Data.Text.Lazy.Builder (Builder, toLazyText, fromText, fromString)

import Staversion.Internal.Aggregate
  ( groupAllPreservingOrderBy,
    showVersionRange
  )
import Staversion.Internal.Query
  ( Query(..),
    sourceDesc,
    PackageName
  )
import Staversion.Internal.Result
  ( Result(..), ResultBody'(..), ResultSource(..), resultSourceDesc,
    AggregatedResult(..), singletonResult
  )
import Staversion.Internal.Cabal (Target(..))
import Staversion.Internal.Log (LogEntry)
import Staversion.Internal.Version (VersionRange)
import qualified Staversion.Internal.Version as V


-- | Format for 'VersionRange'.
type FormatVersion = VersionRange -> Text

-- | Let Cabal format 'VersionRange'.
formatVersionCabal :: FormatVersion
formatVersionCabal :: FormatVersion
formatVersionCabal = String -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. VersionRange -> String
showVersionRange

-- | Similar to 'formatVersionCabal', but it uses the \"caret\"
-- operator (@^>=@) where possible.
formatVersionCabalCaret :: FormatVersion
formatVersionCabalCaret :: FormatVersion
formatVersionCabalCaret = Text -> [Text] -> Text
Text.intercalate Text
" || " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map VersionInterval -> Text
formatVersionIntervalCaret forall b c a. (b -> c) -> (a -> b) -> a -> c
. VersionRange -> [VersionInterval]
V.asVersionIntervals

formatVersionIntervalCaret :: V.VersionInterval -> Text
formatVersionIntervalCaret :: VersionInterval -> Text
formatVersionIntervalCaret VersionInterval
vi = case VersionInterval
vi of
  (V.LowerBound Version
lv Bound
V.InclusiveBound, V.UpperBound Version
uv Bound
V.ExclusiveBound) ->
    if Version -> Version -> Bool
isCaretOK Version
lv Version
uv
    then Text
"^>=" forall a. Semigroup a => a -> a -> a
<> Version -> Text
formatV Version
lv
    else Text
fallback
  VersionInterval
_ -> Text
fallback
  where
    formatV :: Version -> Text
formatV Version
v = String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse String
"." forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Version -> [Int]
V.versionNumbers Version
v
    fallback :: Text
fallback = FormatVersion
formatVersionCabal forall a b. (a -> b) -> a -> b
$ VersionIntervals -> VersionRange
V.fromVersionIntervals forall a b. (a -> b) -> a -> b
$ [VersionInterval] -> VersionIntervals
V.mkVersionIntervals [VersionInterval
vi]

isCaretOK :: V.Version -> V.Version -> Bool
isCaretOK :: Version -> Version -> Bool
isCaretOK Version
inc_lv Version
exc_uv = forall {a}. (Eq a, Num a) => [a] -> [a] -> Bool
isCaretOK' (Version -> [Int]
V.versionNumbers Version
inc_lv) (Version -> [Int]
V.versionNumbers Version
exc_uv) where
  isCaretOK' :: [a] -> [a] -> Bool
isCaretOK' [] [a]
uv'          = [a]
uv' forall a. Eq a => a -> a -> Bool
== [a
0,a
1]
  isCaretOK' [a
x] [a]
uv'         = [a]
uv' forall a. Eq a => a -> a -> Bool
== [a
x,a
1]
  isCaretOK' (a
x : a
y : [a]
_) [a]
uv' = [a]
uv' forall a. Eq a => a -> a -> Bool
== [a
x,a
yforall a. Num a => a -> a -> a
+a
1]



data FormatConfig = FormatConfig { FormatConfig -> FormatVersion
fconfFormatVersion :: FormatVersion
                                 }

-- | 'Left' lines and 'Right' lines are handled differently by
-- 'formatResultBlock'. It puts commas at the right places assuming
-- 'Left' lines are commented out.
type ResultLine = Either Builder Builder

data ResultBlock = RBHead Builder [ResultBlock] -- ^ header and child blocks
                 | RBLines [ResultLine] -- ^ a block, which consists of some lines.


formatAggregatedResults :: FormatConfig -> [AggregatedResult] -> TL.Text
formatAggregatedResults :: FormatConfig -> [AggregatedResult] -> Text
formatAggregatedResults FormatConfig
fconf = Builder -> Text
toLazyText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ResultBlock -> Builder
formatResultBlock forall b c a. (b -> c) -> (a -> b) -> a -> c
. FormatConfig -> [AggregatedResult] -> [ResultBlock]
makeSourceBlocks FormatConfig
fconf

makeSourceBlocks :: FormatConfig -> [AggregatedResult] -> [ResultBlock]
makeSourceBlocks :: FormatConfig -> [AggregatedResult] -> [ResultBlock]
makeSourceBlocks FormatConfig
fconf = forall a b. (a -> b) -> [a] -> [b]
map NonEmpty AggregatedResult -> ResultBlock
sourceBlock forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> [a] -> [NonEmpty a]
groupAllPreservingOrderBy (forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` AggregatedResult -> NonEmpty ResultSource
aggResultIn) where
  sourceBlock :: NonEmpty AggregatedResult -> ResultBlock
sourceBlock results :: NonEmpty AggregatedResult
results@(AggregatedResult
head_ret :| [AggregatedResult]
_) = Builder -> [ResultBlock] -> ResultBlock
RBHead Builder
header forall a b. (a -> b) -> a -> b
$ FormatConfig -> [AggregatedResult] -> [ResultBlock]
makeQueryBlocks FormatConfig
fconf forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NL.toList NonEmpty AggregatedResult
results where
    header :: Builder
header = Builder
"------ " forall a. Semigroup a => a -> a -> a
<> (forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall a b. (a -> b) -> a -> b
$ forall a. a -> NonEmpty a -> NonEmpty a
NL.intersperse Builder
", " forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ResultSource -> Builder
sourceHeader forall a b. (a -> b) -> a -> b
$ AggregatedResult -> NonEmpty ResultSource
aggResultIn AggregatedResult
head_ret)

sourceHeader :: ResultSource -> Builder
sourceHeader :: ResultSource -> Builder
sourceHeader = Text -> Builder
fromText forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResultSource -> Text
resultSourceDesc

makeQueryBlocks :: FormatConfig -> [AggregatedResult] -> [ResultBlock]
makeQueryBlocks :: FormatConfig -> [AggregatedResult] -> [ResultBlock]
makeQueryBlocks FormatConfig
fconf = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [ResultBlock] -> [ResultLine] -> [ResultBlock]
prependLines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr AggregatedResult
-> ([ResultBlock], [ResultLine]) -> ([ResultBlock], [ResultLine])
f ([], []) where
  prependLines :: [ResultBlock] -> [ResultLine] -> [ResultBlock]
prependLines [ResultBlock]
blocks [] = [ResultBlock]
blocks
  prependLines [ResultBlock]
blocks [ResultLine]
rlines = ([ResultLine] -> ResultBlock
RBLines [ResultLine]
rlines) forall a. a -> [a] -> [a]
: [ResultBlock]
blocks
  f :: AggregatedResult
-> ([ResultBlock], [ResultLine]) -> ([ResultBlock], [ResultLine])
f AggregatedResult
ret ([ResultBlock]
blocks, [ResultLine]
rlines) = case (AggregatedResult -> Query
aggResultFor AggregatedResult
ret, AggregatedResult
-> Either String (ResultBody' (Maybe VersionRange))
aggResultBody AggregatedResult
ret) of
    (Query
_, Right (SimpleResultBody Text
name Maybe VersionRange
mver)) -> ([ResultBlock]
blocks, (FormatVersion -> Text -> Maybe VersionRange -> ResultLine
versionLine (FormatConfig -> FormatVersion
fconfFormatVersion FormatConfig
fconf) Text
name Maybe VersionRange
mver) forall a. a -> [a] -> [a]
: [ResultLine]
rlines)
    (Query
_, Right (CabalResultBody String
file Target
target [(Text, Maybe VersionRange)]
pairs)) -> (FormatConfig
-> String -> Target -> [(Text, Maybe VersionRange)] -> ResultBlock
cabalFileSuccessBlock FormatConfig
fconf String
file Target
target [(Text, Maybe VersionRange)]
pairs forall a. a -> [a] -> [a]
: [ResultBlock] -> [ResultLine] -> [ResultBlock]
prependLines [ResultBlock]
blocks [ResultLine]
rlines, [])
    (Query
query, Left String
_) -> case Query -> Either ResultLine ResultBlock
makeQueryErrorReport Query
query of
      Left ResultLine
line -> ([ResultBlock]
blocks, ResultLine
line forall a. a -> [a] -> [a]
: [ResultLine]
rlines)
      Right ResultBlock
block -> (ResultBlock
block forall a. a -> [a] -> [a]
: [ResultBlock] -> [ResultLine] -> [ResultBlock]
prependLines [ResultBlock]
blocks [ResultLine]
rlines, [])

versionLine :: FormatVersion -> PackageName -> Maybe VersionRange -> ResultLine
versionLine :: FormatVersion -> Text -> Maybe VersionRange -> ResultLine
versionLine FormatVersion
_ Text
name Maybe VersionRange
Nothing = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Builder
"-- " forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromText Text
name forall a. Semigroup a => a -> a -> a
<> Builder
" N/A"
versionLine FormatVersion
format_version Text
name (Just VersionRange
ver_range) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> Builder
fromText Text
name forall a. Semigroup a => a -> a -> a
<> Builder
" " forall a. Semigroup a => a -> a -> a
<> (Text -> Builder
fromText forall a b. (a -> b) -> a -> b
$ FormatVersion
format_version VersionRange
ver_range)

makeQueryErrorReport :: Query -> Either ResultLine ResultBlock
makeQueryErrorReport :: Query -> Either ResultLine ResultBlock
makeQueryErrorReport (QueryName Text
name) = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Builder
"-- " forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromText Text
name forall a. Semigroup a => a -> a -> a
<> Builder
" ERROR"
makeQueryErrorReport (QueryCabalFile String
file) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ String -> ResultBlock
errorReportBlock String
file
makeQueryErrorReport (QueryStackYaml String
file) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ String -> ResultBlock
errorReportBlock String
file
makeQueryErrorReport Query
QueryStackYamlDefault = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ String -> ResultBlock
errorReportBlock String
"default stack.yaml"

errorReportBlock :: String -> ResultBlock
errorReportBlock :: String -> ResultBlock
errorReportBlock String
label = [ResultLine] -> ResultBlock
RBLines [forall a b. a -> Either a b
Left Builder
line] where
  line :: Builder
line = Builder
"-- " forall a. Semigroup a => a -> a -> a
<> String -> Builder
fromString String
label forall a. Semigroup a => a -> a -> a
<> Builder
" ERROR"

cabalFileSuccessBlock :: FormatConfig -> FilePath -> Target -> [(PackageName, Maybe VersionRange)] -> ResultBlock
cabalFileSuccessBlock :: FormatConfig
-> String -> Target -> [(Text, Maybe VersionRange)] -> ResultBlock
cabalFileSuccessBlock FormatConfig
fconf String
file Target
target [(Text, Maybe VersionRange)]
pairs = Builder -> [ResultBlock] -> ResultBlock
RBHead Builder
header [[ResultLine] -> ResultBlock
RBLines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. (a -> b) -> a -> b
$ FormatVersion -> Text -> Maybe VersionRange -> ResultLine
versionLine forall a b. (a -> b) -> a -> b
$ FormatConfig -> FormatVersion
fconfFormatVersion FormatConfig
fconf) [(Text, Maybe VersionRange)]
pairs] where
  header :: Builder
header = Builder
"-- " forall a. Semigroup a => a -> a -> a
<> String -> Builder
fromString String
file forall a. Semigroup a => a -> a -> a
<> Builder
" - " forall a. Semigroup a => a -> a -> a
<> Builder
target_text
  target_text :: Builder
target_text = case Target
target of
    Target
TargetLibrary -> Builder
"library"
    TargetExecutable Text
n -> Builder
"executable " forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromText Text
n
    TargetTestSuite Text
n -> Builder
"test-suite " forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromText Text
n
    TargetBenchmark Text
n -> Builder
"benchmark " forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromText Text
n

formatResultBlock :: ResultBlock -> Builder
formatResultBlock :: ResultBlock -> Builder
formatResultBlock (RBHead Builder
header [ResultBlock]
blocks) = Builder
header forall a. Semigroup a => a -> a -> a
<> Builder
"\n" forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map ResultBlock -> Builder
formatResultBlock [ResultBlock]
blocks)
formatResultBlock (RBLines [ResultLine]
rlines) = (forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ((forall a. Semigroup a => a -> a -> a
<> Builder
"\n") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$ [ResultLine] -> [ResultLine]
tailCommas [ResultLine]
rlines) forall a. Semigroup a => a -> a -> a
<> Builder
"\n" where
  tailCommas :: [ResultLine] -> [ResultLine]
tailCommas = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a} {b}.
(Semigroup a, Semigroup b, IsString a, IsString b) =>
Either a b -> ([Either a b], Bool) -> ([Either a b], Bool)
f ([], Bool
False)
               -- flag: True if it has already encountered the last Right element in the list.
  f :: Either a b -> ([Either a b], Bool) -> ([Either a b], Bool)
f Either a b
eb ([Either a b]
ret, Bool
flag) = let (Either a b
next_e, Bool
next_flag) = forall {a} {b} {a}.
(Semigroup a, Semigroup b, IsString a, IsString b) =>
[a] -> Bool -> Either a b -> (Either a b, Bool)
getNext [Either a b]
ret Bool
flag Either a b
eb
                     in (Either a b
next_eforall a. a -> [a] -> [a]
:[Either a b]
ret, Bool
next_flag)
  getNext :: [a] -> Bool -> Either a b -> (Either a b, Bool)
getNext [] Bool
flag e :: Either a b
e@(Left a
_) = (Either a b
e, Bool
flag)
  getNext [a]
_ Bool
flag (Left a
b) = (forall a b. a -> Either a b
Left (a
b forall a. Semigroup a => a -> a -> a
<> a
","), Bool
flag)
  getNext [a]
_ Bool
False e :: Either a b
e@(Right b
_) = (Either a b
e, Bool
True)
  getNext [a]
_ Bool
True (Right b
b) = (forall a b. b -> Either a b
Right (b
b forall a. Semigroup a => a -> a -> a
<> b
","), Bool
True)