{-# LANGUAGE OverloadedStrings #-}

module Crux.Config.Doc (configDocs) where

import           Config.Schema (sectionsSpec,generateDocs)
import           Data.Function ( on )
import qualified Data.List as L
import           Data.Text ( Text )
import qualified Data.Text as T
import           Prettyprinter
import           Prettyprinter.Util ( reflow )
import           SimpleGetOpt ( OptSpec(..) )

import           Crux.Config
import           Crux.Config.Load (commandLineOptions)

configDocs :: Text -> Config opts -> Doc ann
configDocs :: forall opts ann. Text -> Config opts -> Doc ann
configDocs Text
nm Config opts
cfg =
  [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat [ String -> Doc ann
forall ann. String -> Doc ann
heading String
"Command line flags:"
       , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ OptSpec (EarlyConfig opts) -> Doc ann
forall a ann. OptSpec a -> Doc ann
cmdLineDocs (OptSpec (EarlyConfig opts) -> Doc ann)
-> OptSpec (EarlyConfig opts) -> Doc ann
forall a b. (a -> b) -> a -> b
$ Config opts -> OptSpec (EarlyConfig opts)
forall opts. Config opts -> OptSpec (EarlyConfig opts)
commandLineOptions Config opts
cfg
       , Config opts -> Doc ann
forall a ann. Config a -> Doc ann
envVarDocs Config opts
cfg
       , String -> Doc ann
forall ann. String -> Doc ann
heading String
"Configuration file format:"
       , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow (Doc -> Doc ann) -> Doc -> Doc ann
forall a b. (a -> b) -> a -> b
$ ValueSpec opts -> Doc
forall a. ValueSpec a -> Doc
generateDocs (Text -> SectionsSpec opts -> ValueSpec opts
forall a. Text -> SectionsSpec a -> ValueSpec a
sectionsSpec Text
nm (Config opts -> SectionsSpec opts
forall opts. Config opts -> SectionsSpec opts
cfgFile Config opts
cfg)))
       ]

cmdLineDocs :: OptSpec a -> Doc ann
cmdLineDocs :: forall a ann. OptSpec a -> Doc ann
cmdLineDocs OptSpec a
opts =
  [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat [ Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann
"Parameters:" Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: [Doc ann]
forall {ann}. [Doc ann]
ppParams
       , Doc ann
forall a. Monoid a => a
mempty
       , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ Doc ann
"Flags:" Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: [Doc ann]
forall {ann}. [Doc ann]
ppFlags
       ]
  where
    ppParams :: [Doc ann]
ppParams = let maxLen :: Int
maxLen = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int)
-> ((String, String) -> String) -> (String, String) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> a
fst) ((String, String) -> Int) -> [(String, String)] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OptSpec a -> [(String, String)]
forall a. OptSpec a -> [(String, String)]
progParamDocs OptSpec a
opts
               in ((String, String) -> Doc ann) -> [(String, String)] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> (String, String) -> Doc ann
forall {a} {ann}. Pretty a => Int -> (a, String) -> Doc ann
ppParam Int
maxLen) ([(String, String)] -> [Doc ann])
-> [(String, String)] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ OptSpec a -> [(String, String)]
forall a. OptSpec a -> [(String, String)]
progParamDocs OptSpec a
opts
    ppParam :: Int -> (a, String) -> Doc ann
ppParam Int
l (a
n,String
d) = let pad :: Int
pad = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
d
                      in [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hcat [ a -> Doc ann
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
n
                              , Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> Doc ann) -> Text -> Doc ann
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.replicate (Int
pad Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4) Text
" "
                              , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ Text -> Doc ann
forall ann. Text -> Doc ann
reflow (Text -> Doc ann) -> Text -> Doc ann
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
d ]
    ppFlags :: [Doc ann]
ppFlags = let flagset :: [[Text]]
flagset = (OptDescr a -> [Text]) -> [OptDescr a] -> [[Text]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OptDescr a -> [Text]
forall a. OptDescr a -> [Text]
ppFlag ([OptDescr a] -> [[Text]]) -> [OptDescr a] -> [[Text]]
forall a b. (a -> b) -> a -> b
$ (OptDescr a -> OptDescr a -> Ordering)
-> [OptDescr a] -> [OptDescr a]
forall a. (a -> a -> Ordering) -> [a] -> [a]
L.sortBy ((String, [String]) -> (String, [String]) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ((String, [String]) -> (String, [String]) -> Ordering)
-> (OptDescr a -> (String, [String]))
-> OptDescr a
-> OptDescr a
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` OptDescr a -> (String, [String])
forall {a}. OptDescr a -> (String, [String])
optSort)  ([OptDescr a] -> [OptDescr a]) -> [OptDescr a] -> [OptDescr a]
forall a b. (a -> b) -> a -> b
$ OptSpec a -> [OptDescr a]
forall a. OptSpec a -> [OptDescr a]
progOptions OptSpec a
opts
                  optSort :: OptDescr a -> (String, [String])
optSort OptDescr a
o = (String -> String
forall a. Ord a => [a] -> [a]
L.sort (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ OptDescr a -> String
forall a. OptDescr a -> String
optShortFlags OptDescr a
o String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"zzzzz", [String] -> [String]
forall a. Ord a => [a] -> [a]
L.sort ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ OptDescr a -> [String]
forall a. OptDescr a -> [String]
optLongFlags OptDescr a
o)
                  lengths :: [Int]
lengths = ([Text] -> Int) -> [[Text]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> ([Text] -> [Int]) -> [Text] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Int) -> [Text] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Int
T.length) ([[Text]] -> [Int]) -> [[Text]] -> [Int]
forall a b. (a -> b) -> a -> b
$ [[Text]] -> [[Text]]
forall a. [[a]] -> [[a]]
L.transpose [[Text]]
flagset
                  textLen :: (Int, Text) -> Text
textLen (Int
l,Text
t) = let f :: Text
f = Int -> Text -> Text
T.replicate (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
t) Text
" " in Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
f
                  sizedCols :: [[Text]]
sizedCols = ([Text] -> [Text]) -> [[Text]] -> [[Text]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Int, Text) -> Text) -> [(Int, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, Text) -> Text
textLen ([(Int, Text)] -> [Text])
-> ([Text] -> [(Int, Text)]) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Text] -> [(Int, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
lengths) ([[Text]] -> [[Text]]) -> [[Text]] -> [[Text]]
forall a b. (a -> b) -> a -> b
$ [[Text]]
flagset
                  padLast :: Text -> Doc ann
padLast = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
align (Doc ann -> Doc ann) -> (Text -> Doc ann) -> Text -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Doc ann
forall ann. Text -> Doc ann
reflow
                  prettyLine :: [Text] -> Doc ann
prettyLine = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hcat ([Doc ann] -> Doc ann)
-> ([Text] -> [Doc ann]) -> [Text] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Doc ann], Text -> Doc ann) -> [Doc ann]
forall a b. (a, b) -> a
fst (([Doc ann], Text -> Doc ann) -> [Doc ann])
-> ([Text] -> ([Doc ann], Text -> Doc ann)) -> [Text] -> [Doc ann]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
 -> ([Doc ann], Text -> Doc ann) -> ([Doc ann], Text -> Doc ann))
-> ([Doc ann], Text -> Doc ann)
-> [Text]
-> ([Doc ann], Text -> Doc ann)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Text
c ([Doc ann]
p,Text -> Doc ann
g) -> (Text -> Doc ann
g Text
c Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: Doc ann
forall ann. Doc ann
space Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: [Doc ann]
p, Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty)) ([], Text -> Doc ann
forall ann. Text -> Doc ann
padLast)
              in ([Text] -> Doc ann) -> [[Text]] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Text] -> Doc ann
forall {ann}. [Text] -> Doc ann
prettyLine [[Text]]
sizedCols
    ppFlag :: OptDescr a -> [Text]
    ppFlag :: forall a. OptDescr a -> [Text]
ppFlag OptDescr a
od = let sfs :: Text
sfs = if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (OptDescr a -> String
forall a. OptDescr a -> String
optShortFlags OptDescr a
od) then Text
""
                          else let each :: [Text]
each =
                                     let f :: Char -> Text
f = case OptDescr a -> ArgDescr a
forall a. OptDescr a -> ArgDescr a
optArgument OptDescr a
od of
                                            NoArg OptSetter a
_ -> Char -> Text
T.singleton
                                            ReqArg String
a String -> OptSetter a
_ -> (\Char
c -> Char -> Text
T.singleton Char
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
a)
                                            OptArg String
a Maybe String -> OptSetter a
_ -> (\Char
c -> Char -> Text
T.singleton Char
c Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]")
                                     in Char -> Text
f (Char -> Text) -> String -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OptDescr a -> String
forall a. OptDescr a -> String
optShortFlags OptDescr a
od
                               in Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
",-" [Text]
each
                    lfs :: Text
lfs = if [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (OptDescr a -> [String]
forall a. OptDescr a -> [String]
optLongFlags OptDescr a
od) then Text
""
                          else let each :: [Text]
each =
                                     let f :: String -> Text
f = case OptDescr a -> ArgDescr a
forall a. OptDescr a -> ArgDescr a
optArgument OptDescr a
od of
                                           NoArg OptSetter a
_ -> String -> Text
T.pack
                                           ReqArg String
a String -> OptSetter a
_ -> (\String
s -> String -> Text
T.pack String
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
a)
                                           OptArg String
a Maybe String -> OptSetter a
_ -> (\String
s -> String -> Text
T.pack String
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]")
                                     in String -> Text
f (String -> Text) -> [String] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OptDescr a -> [String]
forall a. OptDescr a -> [String]
optLongFlags OptDescr a
od
                               in Text
"--" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
",--" [Text]
each
                in [ Text
sfs, Text
lfs, String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ OptDescr a -> String
forall a. OptDescr a -> String
optDescription OptDescr a
od ]


envVarDocs :: Config a -> Doc ann
envVarDocs :: forall a ann. Config a -> Doc ann
envVarDocs Config a
cfg
  | [EnvDescr a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EnvDescr a]
vs = Doc ann
forall a. Monoid a => a
mempty
  | Bool
otherwise = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat [ String -> Doc ann
forall ann. String -> Doc ann
heading String
"Environment variables:"
                     , Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 ([Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat ((EnvDescr a -> Doc ann) -> [EnvDescr a] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map EnvDescr a -> Doc ann
forall {opts} {ann}. EnvDescr opts -> Doc ann
pp [EnvDescr a]
vs))
                     ]
    where
    vs :: [EnvDescr a]
vs = Config a -> [EnvDescr a]
forall opts. Config opts -> [EnvDescr opts]
cfgEnv Config a
cfg
    m :: Int
m  = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((EnvDescr a -> Int) -> [EnvDescr a] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> (EnvDescr a -> String) -> EnvDescr a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnvDescr a -> String
forall opts. EnvDescr opts -> String
evName) [EnvDescr a]
vs)
    pp :: EnvDescr opts -> Doc ann
pp EnvDescr opts
v = String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
n) Char
' ') Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> (String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> String -> Doc ann
forall a b. (a -> b) -> a -> b
$ EnvDescr opts -> String
forall opts. EnvDescr opts -> String
evDoc EnvDescr opts
v)
      where n :: String
n = EnvDescr opts -> String
forall opts. EnvDescr opts -> String
evName EnvDescr opts
v

heading :: String -> Doc ann
heading :: forall ann. String -> Doc ann
heading String
x = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat [ Doc ann
forall a. Monoid a => a
mempty
                 , String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
x
                 , String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Int -> Char -> String
forall a. Int -> a -> [a]
replicate (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
x) Char
'=')
                 , Doc ann
forall a. Monoid a => a
mempty ]