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
type FormatVersion = VersionRange -> Text
formatVersionCabal :: FormatVersion
formatVersionCabal :: FormatVersion
formatVersionCabal = String -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. VersionRange -> String
showVersionRange
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
}
type ResultLine = Either Builder Builder
data ResultBlock = RBHead Builder [ResultBlock]
| RBLines [ResultLine]
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
= 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)
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)