1  {-# LANGUAGE OverloadedStrings #-}
  2  {-# LANGUAGE RecordWildCards #-}
  3  
  4  {- |
  5  Module      : Props
  6  Description : Property tests for CLI wrapper generators
  7  
  8  Run:
  9    nix-shell -p "haskellPackages.ghcWithPackages (p: [p.megaparsec p.text p.QuickCheck p.hedgehog])" \
 10      --run "runghc -i. Props.hs"
 11  
 12  Properties tested:
 13    1. Parser totality: no crashes on arbitrary input
 14    2. Preservation: parsed options appear in generated code
 15    3. Idempotence: parse(x) == parse(x)
 16    4. Compilation: generated code is valid Haskell (via GHC)
 17  -}
 18  module Main where
 19  
 20  import Control.DeepSeq (NFData (..), deepseq)
 21  import Data.Char (isAlphaNum, isLower, isUpper)
 22  import Data.Text (Text)
 23  import qualified Data.Text as T
 24  import System.Directory (getTemporaryDirectory, removeFile)
 25  import System.Exit (ExitCode (..))
 26  import System.IO (hClose, hPutStr, openTempFile)
 27  import System.Process (readProcessWithExitCode)
 28  import Test.QuickCheck
 29  
 30  import qualified Aleph.Script.Clap as Clap
 31  import qualified Aleph.Script.Getopt as Getopt
 32  
 33  -- ============================================================================
 34  -- Generators
 35  -- ============================================================================
 36  
 37  -- | Generate realistic-ish help text lines
 38  genHelpLine :: Gen Text
 39  genHelpLine =
 40      frequency
 41          [ (3, genOptionLine)
 42          , (1, genSectionHeader)
 43          , (2, genDescriptionLine)
 44          , (1, pure "")
 45          ]
 46  
 47  -- | Generate a clap-style option line
 48  genOptionLine :: Gen Text
 49  genOptionLine = do
 50      indent <- elements ["  ", "    ", "      "]
 51      short <- frequency [(3, genShortOpt), (1, pure "")]
 52      long <- frequency [(4, genLongOpt), (1, pure "")]
 53      sep <-
 54          if (not (T.null short) && not (T.null long))
 55              then elements [", ", " "]
 56              else pure ""
 57      arg <- frequency [(2, genArgPlaceholder), (1, pure "")]
 58      desc <- genDescription
 59      pure $ indent <> short <> sep <> long <> arg <> "  " <> desc
 60  
 61  genShortOpt :: Gen Text
 62  genShortOpt = do
 63      c <- elements $ ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9']
 64      pure $ "-" <> T.singleton c
 65  
 66  genLongOpt :: Gen Text
 67  genLongOpt = do
 68      parts <- listOf1 $ elements ["foo", "bar", "ignore", "case", "file", "path", "no", "with"]
 69      pure $ "--" <> T.intercalate "-" (take 3 parts)
 70  
 71  genArgPlaceholder :: Gen Text
 72  genArgPlaceholder =
 73      frequency
 74          [
 75              ( 2
 76              , do
 77                  name <- elements ["FILE", "PATH", "NUM", "PATTERN", "DIR", "COUNT"]
 78                  pure $ "=" <> name
 79              )
 80          ,
 81              ( 1
 82              , do
 83                  name <- elements ["FILE", "PATH", "NUM"]
 84                  pure $ " <" <> name <> ">"
 85              )
 86          ]
 87  
 88  genSectionHeader :: Gen Text
 89  genSectionHeader = do
 90      name <- elements ["Options", "Input", "Output", "Search", "Filter", "POSITIONAL ARGUMENTS"]
 91      pure $ name <> ":"
 92  
 93  genDescriptionLine :: Gen Text
 94  genDescriptionLine = do
 95      indent <- elements ["        ", "          ", "            "]
 96      desc <- genDescription
 97      pure $ indent <> desc
 98  
 99  genDescription :: Gen Text
100  genDescription = do
101      words <- listOf $ elements ["the", "a", "file", "to", "use", "for", "output", "input", "match"]
102      pure $ T.unwords (take 10 words)
103  
104  -- | Generate a full help text (clap-style)
105  genHelpText :: Gen Text
106  genHelpText = do
107      header <- elements ["mytool 1.0.0", "Usage: mytool [OPTIONS]", ""]
108      sections <- listOf1 $ do
109          hdr <- genSectionHeader
110          opts <- listOf1 genOptionLine
111          pure $ T.unlines (hdr : opts)
112      pure $ T.unlines (header : sections)
113  
114  -- | Generate GNU-style help text
115  genGnuHelpText :: Gen Text
116  genGnuHelpText = do
117      header <- elements ["Usage: mytool [OPTION]... [FILE]...", "mytool - do something"]
118      opts <- listOf1 genGnuOptionLine
119      pure $ T.unlines (header : opts)
120  
121  -- | Generate a GNU getopt-style option line
122  genGnuOptionLine :: Gen Text
123  genGnuOptionLine = do
124      short <- frequency [(3, Just <$> elements ['a' .. 'z']), (1, pure Nothing)]
125      long <- frequency [(4, Just <$> genLongName), (1, pure Nothing)]
126      arg <- frequency [(2, Just <$> elements ["FILE", "NUM", "DIR"]), (1, pure Nothing)]
127      desc <- genDescription
128      let shortPart = maybe "" (\c -> "-" <> T.singleton c <> ", ") short
129          longPart = maybe "" (\l -> "--" <> l) long
130          argPart = maybe "" ("=" <>) arg
131      case (short, long) of
132          (Nothing, Nothing) -> genGnuOptionLine -- retry, need at least one
133          _ -> pure $ "  " <> shortPart <> longPart <> argPart <> "  " <> desc
134    where
135      genLongName = do
136          parts <- listOf1 $ elements ["foo", "bar", "ignore", "case", "file"]
137          pure $ T.intercalate "-" (take 2 parts)
138  
139  -- | Generate completely random text (for crash testing)
140  genArbitraryText :: Gen Text
141  genArbitraryText = do
142      len <- choose (0, 1000)
143      chars <- vectorOf len arbitrary
144      pure $ T.pack chars
145  
146  -- ============================================================================
147  -- Properties
148  -- ============================================================================
149  
150  -- | Parser never crashes, even on garbage input
151  prop_clap_parser_total :: Property
152  prop_clap_parser_total = forAll genArbitraryText $ \input ->
153      let result = Clap.parseHelp input
154       in result `deepseq` True -- Force evaluation, just check it doesn't crash
155  
156  prop_getopt_parser_total :: Property
157  prop_getopt_parser_total = forAll genArbitraryText $ \input ->
158      let result = Getopt.parseHelp input
159       in result `deepseq` True
160  
161  -- | Parsing is idempotent (parse twice = same result)
162  prop_clap_idempotent :: Property
163  prop_clap_idempotent = forAll genHelpText $ \input ->
164      let p1 = Clap.parseHelp input
165          p2 = Clap.parseHelp input
166       in p1 == p2
167  
168  prop_getopt_idempotent :: Property
169  prop_getopt_idempotent = forAll genHelpText $ \input ->
170      let p1 = Getopt.parseHelp input
171          p2 = Getopt.parseHelp input
172       in p1 == p2
173  
174  -- | Every long option in parsed result appears in generated code
175  prop_clap_options_preserved :: Property
176  prop_clap_options_preserved = forAll genHelpText $ \input ->
177      let parsed = Clap.parseHelp input
178          generated = Clap.generateModule "Test" "test" parsed
179          allOpts = concatMap Clap.secOptions (Clap.helpSections parsed)
180          longNames =
181              [ n
182              | Clap.ClapOption{optLong = Just n} <- allOpts
183              , n /= "help"
184              , n /= "version"
185              ]
186       in all (\n -> n `T.isInfixOf` generated) longNames
187  
188  prop_getopt_options_preserved :: Property
189  prop_getopt_options_preserved = forAll genGnuHelpText $ \input ->
190      let parsed = Getopt.parseHelp input
191          generated = Getopt.generateModule "Test" "test" parsed
192          opts = Getopt.helpOptions parsed
193          longNames =
194              [ n
195              | Getopt.GetoptOption{Getopt.optLong = Just n} <- opts
196              , n /= "help"
197              , n /= "version"
198              ]
199       in all (\n -> n `T.isInfixOf` generated) longNames
200  
201  -- | Generated code contains required structure
202  prop_clap_generated_structure :: Property
203  prop_clap_generated_structure = forAll genHelpText $ \input ->
204      let generated = Clap.generateModule "Test" "test" (Clap.parseHelp input)
205       in and
206              [ "module Aleph.Script.Tools.Test" `T.isInfixOf` generated
207              , "data Options = Options" `T.isInfixOf` generated
208              , "defaults :: Options" `T.isInfixOf` generated
209              , "buildArgs :: Options -> [Text]" `T.isInfixOf` generated
210              , "test :: Options -> [Text] -> Sh Text" `T.isInfixOf` generated
211              ]
212  
213  prop_getopt_generated_structure :: Property
214  prop_getopt_generated_structure = forAll genGnuHelpText $ \input ->
215      let generated = Getopt.generateModule "Test" "test" (Getopt.parseHelp input)
216       in and
217              [ "module Aleph.Script.Tools.Test" `T.isInfixOf` generated
218              , "data Options = Options" `T.isInfixOf` generated
219              , "defaults :: Options" `T.isInfixOf` generated
220              , "buildArgs :: Options -> [Text]" `T.isInfixOf` generated
221              ]
222  
223  -- | Field names are valid Haskell identifiers
224  prop_clap_valid_field_names :: Property
225  prop_clap_valid_field_names = forAll genLongOpt $ \opt ->
226      let name = Clap.optionToHaskellName (T.drop 2 opt) -- drop "--"
227       in not (T.null name) && isValidHaskellIdent name
228  
229  prop_getopt_valid_field_names :: Property
230  prop_getopt_valid_field_names = forAll genLongOpt $ \opt ->
231      let name = Getopt.optionToHaskellName (T.drop 2 opt)
232       in not (T.null name) && isValidHaskellIdent name
233  
234  isValidHaskellIdent :: Text -> Bool
235  isValidHaskellIdent t = case T.uncons t of
236      Nothing -> False
237      Just (c, rest) ->
238          (isLower c || c == '_')
239              && T.all (\x -> isAlphaNum x || x == '_' || x == '\'') rest
240  
241  -- ============================================================================
242  -- Compilation Properties (IO)
243  -- ============================================================================
244  
245  -- | Generated clap code compiles with GHC
246  prop_clap_compiles :: Property
247  prop_clap_compiles = once $ ioProperty $ do
248      let input =
249              T.unlines
250                  [ "Options:"
251                  , "  -v, --verbose          Be verbose"
252                  , "  -f, --file=FILE        Input file"
253                  , "  -n, --count=NUM        Number of items"
254                  , "      --ignore-case      Ignore case"
255                  ]
256          generated = Clap.generateModule "TestClap" "test-clap" (Clap.parseHelp input)
257      compiles generated
258  
259  -- | Generated getopt code compiles with GHC
260  prop_getopt_compiles :: Property
261  prop_getopt_compiles = once $ ioProperty $ do
262      let input =
263              T.unlines
264                  [ "Usage: test [OPTION]..."
265                  , "  -v, --verbose          be verbose"
266                  , "  -f, --file=FILE        input file"
267                  , "  -n, --count=NUM        number of items"
268                  , "      --ignore-case      ignore case"
269                  ]
270          generated = Getopt.generateModule "TestGetopt" "test-getopt" (Getopt.parseHelp input)
271      compiles generated
272  
273  -- | Generated code from random input compiles
274  prop_clap_random_compiles :: Property
275  prop_clap_random_compiles = withMaxSuccess 5 $ forAll genHelpText $ \input ->
276      ioProperty $ do
277          let generated = Clap.generateModule "TestRandom" "test-random" (Clap.parseHelp input)
278          compiles generated
279  
280  prop_getopt_random_compiles :: Property
281  prop_getopt_random_compiles = withMaxSuccess 5 $ forAll genGnuHelpText $ \input ->
282      ioProperty $ do
283          let generated = Getopt.generateModule "TestRandom" "test-random" (Getopt.parseHelp input)
284          compiles generated
285  
286  -- | Check if Haskell code compiles using GHC
287  compiles :: Text -> IO Bool
288  compiles code = do
289      tmpDir <- getTemporaryDirectory
290      (tmpFile, h) <- openTempFile tmpDir "PropTest.hs"
291      hPutStr h (T.unpack code)
292      hClose h
293      -- Use -fno-code to just type-check without generating output
294      -- -i. to find Aleph.Script module
295      (exitCode, _stdout, stderr) <-
296          readProcessWithExitCode
297              "ghc"
298              ["-fno-code", "-i.", tmpFile]
299              ""
300      removeFile tmpFile
301      case exitCode of
302          ExitSuccess -> return True
303          ExitFailure _ -> do
304              putStrLn $ "\n=== COMPILATION FAILED ==="
305              putStrLn $ "Generated code:\n" ++ T.unpack code
306              putStrLn $ "GHC error:\n" ++ stderr
307              putStrLn "==========================="
308              return False
309  
310  -- ============================================================================
311  -- NFData instances for deepseq
312  -- ============================================================================
313  
314  instance NFData Clap.ClapOption where
315      rnf Clap.ClapOption{..} = rnf optShort `seq` rnf optLong `seq` rnf optArg `seq` rnf optDesc
316  
317  instance NFData Clap.ClapPositional where
318      rnf Clap.ClapPositional{..} = rnf posName `seq` rnf posRequired
319  
320  instance NFData Clap.ClapSection where
321      rnf Clap.ClapSection{..} = rnf secName `seq` rnf secOptions
322  
323  instance NFData Clap.ClapHelp where
324      rnf Clap.ClapHelp{..} = rnf helpSections `seq` rnf helpPositionals
325  
326  instance NFData Getopt.GetoptOption where
327      rnf Getopt.GetoptOption{..} =
328          rnf optShort `seq`
329              rnf optLong `seq`
330                  rnf optArg `seq`
331                      rnf optArgOptional `seq`
332                          rnf optDesc
333  
334  instance NFData Getopt.GetoptHelp where
335      rnf Getopt.GetoptHelp{..} = rnf helpOptions `seq` rnf helpUsage
336  
337  -- ============================================================================
338  -- Main
339  -- ============================================================================
340  
341  main :: IO ()
342  main = do
343      putStrLn "=== Property Tests for CLI Wrapper Generators ==="
344      putStrLn ""
345  
346      let args = stdArgs{maxSuccess = 50} -- 50 is fast enough for quick checks
347      putStrLn "-- Clap Parser --"
348      putStr "  parser_total: "
349      quickCheckWith args prop_clap_parser_total
350      putStr "  idempotent: "
351      quickCheckWith args prop_clap_idempotent
352      putStr "  options_preserved: "
353      quickCheckWith args prop_clap_options_preserved
354      putStr "  generated_structure: "
355      quickCheckWith args prop_clap_generated_structure
356      putStr "  valid_field_names: "
357      quickCheckWith args prop_clap_valid_field_names
358  
359      putStrLn ""
360      putStrLn "-- GNU Getopt Parser --"
361      putStr "  parser_total: "
362      quickCheckWith args prop_getopt_parser_total
363      putStr "  idempotent: "
364      quickCheckWith args prop_getopt_idempotent
365      putStr "  options_preserved: "
366      quickCheckWith args prop_getopt_options_preserved
367      putStr "  generated_structure: "
368      quickCheckWith args prop_getopt_generated_structure
369      putStr "  valid_field_names: "
370      quickCheckWith args prop_getopt_valid_field_names
371  
372      -- Compilation tests are slow (spawn GHC subprocess), skip by default
373      -- Uncomment to run:
374      -- putStrLn ""
375      -- putStrLn "-- Compilation (requires GHC) --"
376      -- putStr "  clap_compiles: "
377      -- quickCheckWith args prop_clap_compiles
378      -- putStr "  getopt_compiles: "
379      -- quickCheckWith args prop_getopt_compiles
380  
381      putStrLn ""
382      putStrLn "=== All properties passed ==="