{-# LANGUAGE FlexibleContexts #-}

module Network.TypedProtocol.Documentation.DefaultMain
where

import qualified Data.Text.Lazy as LText
import qualified Text.Blaze.Html.Renderer.Pretty as Pretty
import Data.SerDoc.Class hiding (info)
import Data.Word
import qualified Network.TypedProtocol.Documentation.Html as HTML
import qualified Network.TypedProtocol.Documentation.Text as TextRender
import Network.TypedProtocol.Documentation.Types
import Options.Applicative
import Control.Monad
import System.FilePath
import qualified Data.Aeson as JSON
import Data.Text.Encoding
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text as Text
import System.Exit
import System.IO
import System.IO.Unsafe

data MainOptions =
  MainOptions
    { MainOptions -> Maybe FilePath
moOutputFile :: Maybe FilePath
    , MainOptions -> OutputFormat
moOutputFormat :: OutputFormat
    , MainOptions -> Bool
moListProtocols :: Bool
    }

data OutputFormat
  = OutputAuto
  | OutputText
  | OutputHtml
  | OutputJSON
  deriving (Int -> OutputFormat -> ShowS
[OutputFormat] -> ShowS
OutputFormat -> FilePath
(Int -> OutputFormat -> ShowS)
-> (OutputFormat -> FilePath)
-> ([OutputFormat] -> ShowS)
-> Show OutputFormat
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OutputFormat -> ShowS
showsPrec :: Int -> OutputFormat -> ShowS
$cshow :: OutputFormat -> FilePath
show :: OutputFormat -> FilePath
$cshowList :: [OutputFormat] -> ShowS
showList :: [OutputFormat] -> ShowS
Show, ReadPrec [OutputFormat]
ReadPrec OutputFormat
Int -> ReadS OutputFormat
ReadS [OutputFormat]
(Int -> ReadS OutputFormat)
-> ReadS [OutputFormat]
-> ReadPrec OutputFormat
-> ReadPrec [OutputFormat]
-> Read OutputFormat
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS OutputFormat
readsPrec :: Int -> ReadS OutputFormat
$creadList :: ReadS [OutputFormat]
readList :: ReadS [OutputFormat]
$creadPrec :: ReadPrec OutputFormat
readPrec :: ReadPrec OutputFormat
$creadListPrec :: ReadPrec [OutputFormat]
readListPrec :: ReadPrec [OutputFormat]
Read, OutputFormat -> OutputFormat -> Bool
(OutputFormat -> OutputFormat -> Bool)
-> (OutputFormat -> OutputFormat -> Bool) -> Eq OutputFormat
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OutputFormat -> OutputFormat -> Bool
== :: OutputFormat -> OutputFormat -> Bool
$c/= :: OutputFormat -> OutputFormat -> Bool
/= :: OutputFormat -> OutputFormat -> Bool
Eq, Eq OutputFormat
Eq OutputFormat =>
(OutputFormat -> OutputFormat -> Ordering)
-> (OutputFormat -> OutputFormat -> Bool)
-> (OutputFormat -> OutputFormat -> Bool)
-> (OutputFormat -> OutputFormat -> Bool)
-> (OutputFormat -> OutputFormat -> Bool)
-> (OutputFormat -> OutputFormat -> OutputFormat)
-> (OutputFormat -> OutputFormat -> OutputFormat)
-> Ord OutputFormat
OutputFormat -> OutputFormat -> Bool
OutputFormat -> OutputFormat -> Ordering
OutputFormat -> OutputFormat -> OutputFormat
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: OutputFormat -> OutputFormat -> Ordering
compare :: OutputFormat -> OutputFormat -> Ordering
$c< :: OutputFormat -> OutputFormat -> Bool
< :: OutputFormat -> OutputFormat -> Bool
$c<= :: OutputFormat -> OutputFormat -> Bool
<= :: OutputFormat -> OutputFormat -> Bool
$c> :: OutputFormat -> OutputFormat -> Bool
> :: OutputFormat -> OutputFormat -> Bool
$c>= :: OutputFormat -> OutputFormat -> Bool
>= :: OutputFormat -> OutputFormat -> Bool
$cmax :: OutputFormat -> OutputFormat -> OutputFormat
max :: OutputFormat -> OutputFormat -> OutputFormat
$cmin :: OutputFormat -> OutputFormat -> OutputFormat
min :: OutputFormat -> OutputFormat -> OutputFormat
Ord, Int -> OutputFormat
OutputFormat -> Int
OutputFormat -> [OutputFormat]
OutputFormat -> OutputFormat
OutputFormat -> OutputFormat -> [OutputFormat]
OutputFormat -> OutputFormat -> OutputFormat -> [OutputFormat]
(OutputFormat -> OutputFormat)
-> (OutputFormat -> OutputFormat)
-> (Int -> OutputFormat)
-> (OutputFormat -> Int)
-> (OutputFormat -> [OutputFormat])
-> (OutputFormat -> OutputFormat -> [OutputFormat])
-> (OutputFormat -> OutputFormat -> [OutputFormat])
-> (OutputFormat -> OutputFormat -> OutputFormat -> [OutputFormat])
-> Enum OutputFormat
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: OutputFormat -> OutputFormat
succ :: OutputFormat -> OutputFormat
$cpred :: OutputFormat -> OutputFormat
pred :: OutputFormat -> OutputFormat
$ctoEnum :: Int -> OutputFormat
toEnum :: Int -> OutputFormat
$cfromEnum :: OutputFormat -> Int
fromEnum :: OutputFormat -> Int
$cenumFrom :: OutputFormat -> [OutputFormat]
enumFrom :: OutputFormat -> [OutputFormat]
$cenumFromThen :: OutputFormat -> OutputFormat -> [OutputFormat]
enumFromThen :: OutputFormat -> OutputFormat -> [OutputFormat]
$cenumFromTo :: OutputFormat -> OutputFormat -> [OutputFormat]
enumFromTo :: OutputFormat -> OutputFormat -> [OutputFormat]
$cenumFromThenTo :: OutputFormat -> OutputFormat -> OutputFormat -> [OutputFormat]
enumFromThenTo :: OutputFormat -> OutputFormat -> OutputFormat -> [OutputFormat]
Enum, OutputFormat
OutputFormat -> OutputFormat -> Bounded OutputFormat
forall a. a -> a -> Bounded a
$cminBound :: OutputFormat
minBound :: OutputFormat
$cmaxBound :: OutputFormat
maxBound :: OutputFormat
Bounded)

parseOutputFormat :: String -> Maybe OutputFormat
parseOutputFormat :: FilePath -> Maybe OutputFormat
parseOutputFormat FilePath
"auto" = OutputFormat -> Maybe OutputFormat
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return OutputFormat
OutputAuto
parseOutputFormat FilePath
"text" = OutputFormat -> Maybe OutputFormat
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return OutputFormat
OutputText
parseOutputFormat FilePath
"html" = OutputFormat -> Maybe OutputFormat
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return OutputFormat
OutputHtml
parseOutputFormat FilePath
"json" = OutputFormat -> Maybe OutputFormat
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return OutputFormat
OutputJSON
parseOutputFormat FilePath
_ = Maybe OutputFormat
forall a. Maybe a
Nothing

pMainOptions :: Parser MainOptions
pMainOptions :: Parser MainOptions
pMainOptions =
  Maybe FilePath -> OutputFormat -> Bool -> MainOptions
MainOptions
    (Maybe FilePath -> OutputFormat -> Bool -> MainOptions)
-> Parser (Maybe FilePath)
-> Parser (OutputFormat -> Bool -> MainOptions)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM (Maybe FilePath)
-> Mod OptionFields (Maybe FilePath) -> Parser (Maybe FilePath)
forall a. ReadM a -> Mod OptionFields a -> Parser a
option (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath)
-> ReadM FilePath -> ReadM (Maybe FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM FilePath
forall s. IsString s => ReadM s
str)
          ( Char -> Mod OptionFields (Maybe FilePath)
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'o'
          Mod OptionFields (Maybe FilePath)
-> Mod OptionFields (Maybe FilePath)
-> Mod OptionFields (Maybe FilePath)
forall a. Semigroup a => a -> a -> a
<> Maybe FilePath -> Mod OptionFields (Maybe FilePath)
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value Maybe FilePath
forall a. Maybe a
Nothing
          Mod OptionFields (Maybe FilePath)
-> Mod OptionFields (Maybe FilePath)
-> Mod OptionFields (Maybe FilePath)
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields (Maybe FilePath)
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"FILE"
          Mod OptionFields (Maybe FilePath)
-> Mod OptionFields (Maybe FilePath)
-> Mod OptionFields (Maybe FilePath)
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields (Maybe FilePath)
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Output file (default: stdout)"
          )
    Parser (OutputFormat -> Bool -> MainOptions)
-> Parser OutputFormat -> Parser (Bool -> MainOptions)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadM OutputFormat
-> Mod OptionFields OutputFormat -> Parser OutputFormat
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ((FilePath -> Maybe OutputFormat) -> ReadM OutputFormat
forall a. (FilePath -> Maybe a) -> ReadM a
maybeReader FilePath -> Maybe OutputFormat
parseOutputFormat)
          ( Char -> Mod OptionFields OutputFormat
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'f'
          Mod OptionFields OutputFormat
-> Mod OptionFields OutputFormat -> Mod OptionFields OutputFormat
forall a. Semigroup a => a -> a -> a
<> OutputFormat -> Mod OptionFields OutputFormat
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value OutputFormat
OutputAuto
          Mod OptionFields OutputFormat
-> Mod OptionFields OutputFormat -> Mod OptionFields OutputFormat
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields OutputFormat
forall (f :: * -> *) a. HasMetavar f => FilePath -> Mod f a
metavar FilePath
"FORMAT"
          Mod OptionFields OutputFormat
-> Mod OptionFields OutputFormat -> Mod OptionFields OutputFormat
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod OptionFields OutputFormat
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Output format; one of: html, text, json, auto"
          )
    Parser (Bool -> MainOptions) -> Parser Bool -> Parser MainOptions
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
switch
          (  FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"list-protocols"
          Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => FilePath -> Mod f a
long FilePath
"list"
          Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> Char -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'l'
          Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> FilePath -> Mod FlagFields Bool
forall (f :: * -> *) a. FilePath -> Mod f a
help FilePath
"Print a list of protocols and exit"
          )


defaultMain :: ( HasInfo codec (DefEnumEncoding codec)
               , HasInfo codec Word32
               ) => [ProtocolDescription codec] -> IO ()
defaultMain :: forall codec.
(HasInfo codec (DefEnumEncoding codec), HasInfo codec Word32) =>
[ProtocolDescription codec] -> IO ()
defaultMain [ProtocolDescription codec]
descriptions = do
  mainOptions <- ParserInfo MainOptions -> IO MainOptions
forall a. ParserInfo a -> IO a
execParser (ParserInfo MainOptions -> IO MainOptions)
-> ParserInfo MainOptions -> IO MainOptions
forall a b. (a -> b) -> a -> b
$ Parser MainOptions -> InfoMod MainOptions -> ParserInfo MainOptions
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser MainOptions
pMainOptions Parser MainOptions
-> Parser (MainOptions -> MainOptions) -> Parser MainOptions
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser (MainOptions -> MainOptions)
forall a. Parser (a -> a)
helper) InfoMod MainOptions
forall a. InfoMod a
fullDesc
  if moListProtocols mainOptions then do
    forM_ descriptions $ \ProtocolDescription codec
d -> do
      FilePath -> IO ()
putStrLn (ProtocolDescription codec -> FilePath
forall codec. ProtocolDescription codec -> FilePath
protocolName ProtocolDescription codec
d)
  else do
    let write = (FilePath -> IO ())
-> (FilePath -> FilePath -> IO ())
-> Maybe FilePath
-> FilePath
-> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FilePath -> IO ()
putStrLn FilePath -> FilePath -> IO ()
writeFile (Maybe FilePath -> FilePath -> IO ())
-> Maybe FilePath -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ MainOptions -> Maybe FilePath
moOutputFile MainOptions
mainOptions
        render = OutputFormat
-> Maybe FilePath -> [ProtocolDescription codec] -> FilePath
forall codec.
(HasInfo codec (DefEnumEncoding codec), HasInfo codec Word32) =>
OutputFormat
-> Maybe FilePath -> [ProtocolDescription codec] -> FilePath
getRenderer (MainOptions -> OutputFormat
moOutputFormat MainOptions
mainOptions) (MainOptions -> Maybe FilePath
moOutputFile MainOptions
mainOptions)
    write . render $ descriptions

getRenderer :: ( HasInfo codec (DefEnumEncoding codec)
               , HasInfo codec Word32
               )
            => OutputFormat
            -> Maybe FilePath
            -> [ProtocolDescription codec]
            -> String
getRenderer :: forall codec.
(HasInfo codec (DefEnumEncoding codec), HasInfo codec Word32) =>
OutputFormat
-> Maybe FilePath -> [ProtocolDescription codec] -> FilePath
getRenderer OutputFormat
OutputAuto Maybe FilePath
path =
  case ShowS
takeExtension ShowS -> Maybe FilePath -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe FilePath
path of
    Just FilePath
".html" -> OutputFormat
-> Maybe FilePath -> [ProtocolDescription codec] -> FilePath
forall codec.
(HasInfo codec (DefEnumEncoding codec), HasInfo codec Word32) =>
OutputFormat
-> Maybe FilePath -> [ProtocolDescription codec] -> FilePath
getRenderer OutputFormat
OutputHtml Maybe FilePath
path
    Just FilePath
".htm" -> OutputFormat
-> Maybe FilePath -> [ProtocolDescription codec] -> FilePath
forall codec.
(HasInfo codec (DefEnumEncoding codec), HasInfo codec Word32) =>
OutputFormat
-> Maybe FilePath -> [ProtocolDescription codec] -> FilePath
getRenderer OutputFormat
OutputHtml Maybe FilePath
path
    Just FilePath
".json" -> OutputFormat
-> Maybe FilePath -> [ProtocolDescription codec] -> FilePath
forall codec.
(HasInfo codec (DefEnumEncoding codec), HasInfo codec Word32) =>
OutputFormat
-> Maybe FilePath -> [ProtocolDescription codec] -> FilePath
getRenderer OutputFormat
OutputJSON Maybe FilePath
path
    Just FilePath
".txt" -> OutputFormat
-> Maybe FilePath -> [ProtocolDescription codec] -> FilePath
forall codec.
(HasInfo codec (DefEnumEncoding codec), HasInfo codec Word32) =>
OutputFormat
-> Maybe FilePath -> [ProtocolDescription codec] -> FilePath
getRenderer OutputFormat
OutputText Maybe FilePath
path
    Maybe FilePath
Nothing -> FilePath -> [ProtocolDescription codec] -> FilePath
forall a. FilePath -> a
abort FilePath
"Cannot detect output file format"
    Just FilePath
ext -> FilePath -> [ProtocolDescription codec] -> FilePath
forall a. FilePath -> a
abort (FilePath -> [ProtocolDescription codec] -> FilePath)
-> FilePath -> [ProtocolDescription codec] -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
"Cannot detect output file format from extension " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> FilePath
show FilePath
ext
getRenderer OutputFormat
OutputHtml Maybe FilePath
_ =
  Html -> FilePath
Pretty.renderHtml (Html -> FilePath)
-> ([ProtocolDescription codec] -> Html)
-> [ProtocolDescription codec]
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Html
HTML.wrapDocument (Html -> Html)
-> ([ProtocolDescription codec] -> Html)
-> [ProtocolDescription codec]
-> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ProtocolDescription codec] -> Html
forall codec.
(HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec)) =>
[ProtocolDescription codec] -> Html
HTML.renderProtocolDescriptions
getRenderer OutputFormat
OutputText Maybe FilePath
_ =
  Text -> FilePath
LText.unpack (Text -> FilePath)
-> ([ProtocolDescription codec] -> Text)
-> [ProtocolDescription codec]
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ProtocolDescription codec] -> Text
forall codec.
(HasInfo codec Word32, HasInfo codec (DefEnumEncoding codec)) =>
[ProtocolDescription codec] -> Text
TextRender.renderProtocolDescriptions
getRenderer OutputFormat
OutputJSON Maybe FilePath
_ =
  Text -> FilePath
Text.unpack (Text -> FilePath)
-> ([ProtocolDescription codec] -> Text)
-> [ProtocolDescription codec]
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> ([ProtocolDescription codec] -> ByteString)
-> [ProtocolDescription codec]
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LazyByteString -> ByteString
LBS.toStrict (LazyByteString -> ByteString)
-> ([ProtocolDescription codec] -> LazyByteString)
-> [ProtocolDescription codec]
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ProtocolDescription codec] -> LazyByteString
forall a. ToJSON a => a -> LazyByteString
JSON.encode

abort :: String -> a
abort :: forall a. FilePath -> a
abort FilePath
msg = IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ do
  Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr FilePath
msg
  IO a
forall a. IO a
exitFailure