cartel-0.16.0.0: tests/cartel-visual-test.hs

-- | Generates random Cabal text.  See the 'help' function below
-- for details on what arguments to use.
module Main where

import Cartel.Generators
import System.Environment
import Data.Either
import Text.Read (readMaybe)
import System.Random
import System.Exit
import qualified System.IO as IO
import Multiarg

maxSize :: Word
maxSize = 10

help :: (String -> String)
help pn = unlines
  [ pn ++ " - generates random Cabal text."
  , "Options:"
  , "  --size INT - runs generator with the given size."
  , "               INT must be non-negative.  Larger INT will"
  , "               result in larger results."
  , "  --seed INT - runs generator with the given seed."
  , "  Without these options, a random seed is chosen, and"
  , "  a random size between 0 and " ++ show maxSize ++ " is chosen."
  ]

opts :: [OptSpec (IO (Either Word Int))]
opts =
  [ optSpec "" ["size"] (OneArg (fmap Left . readVal))
  , optSpec "" ["seed"] (OneArg (fmap Right . readVal))
  ]

failOnPosArg :: IO a
failOnPosArg = do
  pn <- getProgName
  fail $ pn ++ " does not accept positional arguments."

finalOptions :: [Either Word Int] -> IO (Word, Int)
finalOptions ls = do
  let (ws, is) = partitionEithers ls
  sz <- case safeLast ws of
    Nothing -> randomRIO (0, maxSize)
    Just x -> return x
  sd <- case safeLast is of
    Nothing -> randomIO
    Just x -> return x
  return (sz, sd)

safeLast :: [a] -> Maybe a
safeLast xs
  | null xs = Nothing
  | otherwise = Just . last $ xs

readVal :: Read a => String -> IO a
readVal s = maybe (fail $ "could not read string: " ++ s) return
  . readMaybe $ s

main :: IO ()
main = do
  eithersActs <- parseCommandLine help opts (const failOnPosArg)
  eithers <- sequence eithersActs
  (sz, sd) <- finalOptions eithers
  case genCabalText sz sd of
    Left e -> do
      IO.hPutStrLn IO.stderr "could not generate Cabal text."
      IO.hPutStr IO.stderr e
      exitFailure
    Right g -> printHeader sz sd >> putStr g >> exitSuccess

printHeader :: Word -> Int -> IO ()
printHeader sz sd = putStr $ unlines
  [ replicate 50 '-'
  , "-- below - size: " ++ show sz ++ " seed: " ++ show sd
  , replicate 50 '-'
  ]