never executed always true always false

    1 {-# LANGUAGE LambdaCase #-}
    2 
    3 {-# OPTIONS_HADDOCK hide #-}
    4 {-# OPTIONS_GHC -fno-warn-deprecations #-}
    5 
    6 module Options.Applicative.Discrimination
    7     (
    8     -- * Type (re-export from Cardano.Address)
    9       NetworkTag(..)
   10     , fromNetworkTag
   11 
   12     -- * Applicative Parser
   13     , networkTagOpt
   14     ) where
   15 
   16 import Prelude
   17 
   18 import Cardano.Address
   19     ( NetworkDiscriminant (..), NetworkTag (..) )
   20 import Cardano.Address.Style.Shelley
   21     ( Shelley )
   22 import Data.List
   23     ( intercalate )
   24 import Options.Applicative
   25     ( Parser
   26     , completer
   27     , eitherReader
   28     , helpDoc
   29     , listCompleter
   30     , long
   31     , metavar
   32     , option
   33     , (<|>)
   34     )
   35 import Options.Applicative.Help.Pretty
   36     ( string, vsep )
   37 import Options.Applicative.Style
   38     ( Style (..) )
   39 import Text.Read
   40     ( readMaybe )
   41 
   42 import qualified Cardano.Address.Style.Byron as Byron
   43 import qualified Cardano.Address.Style.Shelley as Shelley
   44 
   45 -- | Construct a Shelley 'NetworkDiscriminant' from a network tag. Fails loudly
   46 -- if not possible.
   47 fromNetworkTag :: MonadFail m => NetworkTag -> m (NetworkDiscriminant Shelley)
   48 fromNetworkTag tag =
   49     case (Shelley.mkNetworkDiscriminant . fromIntegral . unNetworkTag) tag of
   50         Left Shelley.ErrWrongNetworkTag{} -> do
   51             fail "Invalid network tag. Must be between [0, 15]"
   52         Right discriminant ->
   53             pure discriminant
   54 
   55 --
   56 -- Applicative Parser
   57 --
   58 
   59 -- | Parse a 'NetworkTag' from the command-line, as an option
   60 networkTagOpt :: Style -> Parser NetworkTag
   61 networkTagOpt style = option (eitherReader reader) $ mempty
   62     <> metavar "NETWORK-TAG"
   63     <> long "network-tag"
   64     <> helpDoc  (Just (vsep (string <$> doc style)))
   65     <> completer (listCompleter $ show <$> tagsFor style)
   66   where
   67     doc style' =
   68         [ "A tag which identifies a Cardano network."
   69         , ""
   70         , header
   71         ]
   72         ++ (fmtAllowedKeyword <$> ("" : allowedKeywords style'))
   73         ++
   74         [ ""
   75         , "...or alternatively, an explicit network tag as an integer."
   76         ]
   77       where
   78         header = case style' of
   79             Byron ->
   80                 "┌ Byron / Icarus ──────────"
   81             Icarus ->
   82                 "┌ Byron / Icarus ──────────"
   83             Shelley ->
   84                 "┌ Shelley ─────────────────"
   85             Shared ->
   86                 "┌ Shared ──────────────────"
   87         fmtAllowedKeyword network =
   88             "│ " <> network
   89 
   90     tagsFor = \case
   91         Byron ->
   92             [ unNetworkTag (snd Byron.byronMainnet)
   93             , unNetworkTag (snd Byron.byronStaging)
   94             , unNetworkTag (snd Byron.byronTestnet)
   95             , unNetworkTag (snd Byron.byronPreprod)
   96             , unNetworkTag (snd Byron.byronPreview)
   97             ]
   98         Icarus ->
   99             tagsFor Byron
  100         Shelley ->
  101             [ unNetworkTag Shelley.shelleyMainnet
  102             , unNetworkTag Shelley.shelleyTestnet
  103             ]
  104         Shared ->
  105             [ unNetworkTag Shelley.shelleyMainnet
  106             , unNetworkTag Shelley.shelleyTestnet
  107             ]
  108 
  109     reader str = maybe (Left err) Right
  110         ((NetworkTag <$> readMaybe str) <|> (readKeywordMaybe str style))
  111       where
  112         err =
  113             "Invalid network tag. Must be an integer value or one of the \
  114             \allowed keywords: " <> intercalate ", " (allowedKeywords style)
  115 
  116     readKeywordMaybe str = \case
  117         Byron | str == "mainnet" -> pure (snd Byron.byronMainnet)
  118         Byron | str == "staging" -> pure (snd Byron.byronStaging)
  119         Byron | str == "testnet" -> pure (snd Byron.byronTestnet)
  120         Byron | str == "preview" -> pure (snd Byron.byronPreview)
  121         Byron | str == "preprod" -> pure (snd Byron.byronPreprod)
  122         Icarus -> readKeywordMaybe str Byron
  123         Shelley | str == "mainnet" -> pure Shelley.shelleyMainnet
  124         Shelley | str == "testnet" -> pure Shelley.shelleyTestnet
  125         Shelley | str == "preview" -> pure Shelley.shelleyTestnet
  126         Shelley | str == "preprod" -> pure Shelley.shelleyTestnet
  127         Shared | str == "mainnet" -> pure Shelley.shelleyMainnet
  128         Shared | str == "testnet" -> pure Shelley.shelleyTestnet
  129         Shared | str == "preview" -> pure Shelley.shelleyTestnet
  130         Shared | str == "preprod" -> pure Shelley.shelleyTestnet
  131         _ -> Nothing
  132 
  133     allowedKeywords = \case
  134         Byron -> ["mainnet", "staging", "testnet", "preview", "preprod"]
  135         Icarus -> allowedKeywords Byron
  136         Shelley -> ["mainnet", "testnet", "preview", "preprod"]
  137         Shared -> allowedKeywords Shelley