GenerateTestJSON.hs

{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE NamedFieldPuns       #-}
{-# LANGUAGE RecordWildCards      #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main where

import           Control.Applicative
import           Control.Monad.State        as State
import           Data.Maybe
import           System.Exit
import           System.IO                 (stdin, stderr, stdout, IOMode(..))
import           System.FilePath           (splitExtension, (<.>), (</>))
import           System.Directory          (removeFile, createDirectoryIfMissing)
import           System.Process            (system)
import           Control.Monad             (forM_, forM, when)
import           Control.Exception         (assert)
import qualified Data.ByteString.Lazy.Char8 as BSL
import qualified Data.HashMap.Strict        as Map
import qualified Data.Set                   as Set
import           Data.Monoid               ((<>))
import           Data.Aeson                (Value(..), eitherDecode, encode, FromJSON(..), ToJSON(..))
import           Data.Function             (on)
import           Data.List
import qualified Data.Text                  as Text
import qualified Data.Text.IO               as Text
import           Data.Text                 (Text)
import qualified Data.Vector                as V
import           Data.Scientific           (scientific, Scientific)
import           Text.PrettyPrint.GenericPretty (pretty)
import           Test.QuickCheck

import           Data.Aeson.AutoType.CodeGen(writeModule, runModule, Lang(..))
import           Data.Aeson.AutoType.Extract
import           Data.Aeson.AutoType.Format
import           Data.Aeson.AutoType.Pretty
import           Data.Aeson.AutoType.Split
import           Data.Aeson.AutoType.Test
import           Data.Aeson.AutoType.Type
import           Data.Aeson.AutoType.Util
import           Options.Applicative

import           CommonCLI

data Options = Options {
                 tyOpts    :: TypeOpts
               , keep      :: Bool
               , stem      :: FilePath
               , count     :: Int
               , size      :: Int
               }

optParser :: Parser Options
optParser  =
    Options  <$> tyOptParser
             <*> switch    (long "keep"                  <> help "Also keep successful tests"  )
             <*> strOption (long "stem"  <> value "Test" <> help "Output filename stem"        )
             <*> intOpt    (long "count" <> value 100    <> help "Number of tests to perform"  )
             <*> intOpt    (long "size"  <> value 10     <> help "size of generated test cases")
             -- <*> some (argument str (metavar "FILES..."))
  where
    intOpt = option auto

-- | Report an error to error output.
report   :: Text -> IO ()
report    = Text.hPutStrLn stderr

-- | Report an error and terminate the program.
fatal    :: Text -> IO ()
fatal msg = do report msg
               exitFailure

-- | Read JSON and extract @Type@ information from it.
extractTypeFromJSONFile :: (String -> IO ()) -> FilePath -> IO (Maybe Type)
extractTypeFromJSONFile myTrace inputFilename =
      withFileOrHandle inputFilename ReadMode stdin $ \hIn ->
        -- First we decode JSON input into Aeson's Value type
        do bs <- BSL.hGetContents hIn
           Text.hPutStrLn stderr $ "Processing " `Text.append` Text.pack (show inputFilename)
           case eitherDecode bs of
             Left  err -> do
               report $ Text.concat ["Cannot decode JSON input from "
                                    ,Text.pack (show inputFilename)
                                    ,"\n"
                                    , Text.pack err]
               return Nothing
             Right v   -> do -- If decoding JSON was successful...
               -- We extract type structure from the JSON value.
               let t        = extractType v
               --myTrace $ "Type: " ++ pretty t
               return $ Just t


vectorWithoutDuplicates ::  Ord b => Int -> Gen b -> Gen [b]
vectorWithoutDuplicates i gen = take i
                              .  removeDuplicates
                             <$> infiniteListOf gen

removeDuplicates ::  Ord a => [a] -> [a]
removeDuplicates list = filterM checkDup list `evalState` Set.empty
  where
    checkDup x = do seen <- State.get
                    if x `Set.member` seen
                      then
                        return False
                      else do
                        State.put $ x `Set.insert` seen
                        return True

-- TODO: check for generic Ord?
instance Ord Value where
  Null       `compare`  Null      = EQ
  Null       `compare`  _         = LT
  _          `compare`  Null      = GT
  (Bool   a) `compare` (Bool   b) = a `compare` b
  (Bool   a) `compare`  _         = LT
  _          `compare` (Bool   b) = GT
  (Number a) `compare` (Number b) = a `compare` b
  (Number _) `compare`  _         = LT
  _          `compare` (Number _) = GT
  (String a) `compare` (String b) = a `compare` b
  (String a) `compare` _          = LT
  _          `compare` (String b) = GT
  (Array  a) `compare` (Array  b) = a `compare` b
  (Array  a) `compare` _          = LT
  _          `compare` (Array  b) = GT
  (Object a) `compare` (Object b) = Map.toList a `compare` Map.toList b

-- | Take a set of JSON input filenames, Haskell output filename, and generate module parsing these JSON files.
generateTestJSONs :: Options -> IO ()
generateTestJSONs Options {tyOpts=TyOptions {..},
                           ..}= do
    createDirectoryIfMissing True "output"
    testValues :: [Value] <- generate $
                               resize size $
                                 vectorWithoutDuplicates 100 arbitraryTopValue
    results               <- forM (zip3 inputFilenames outputFilenames testValues) $
      \(inputFilename, outputFilename, jsonValue) -> do
        BSL.writeFile inputFilename $ encode jsonValue
        -- Read type from each file
        typeForEachFile  <- catMaybes <$> mapM (extractTypeFromJSONFile myTrace) [inputFilename]
        -- Unify all input types
        when (null typeForEachFile) $ do
          report "No valid JSON input file..."
          exitFailure
        let finalType = foldr1 unifyTypes typeForEachFile
        -- We split different dictionary labels to become different type trees (and thus different declarations.)
        let splitted = splitTypeByLabel toplevelName finalType
        --myTrace $ "SPLITTED: " ++ pretty splitted
        assert (not $ any hasNonTopTObj $ Map.elems splitted) $ do
          -- We compute which type labels are candidates for unification
          let uCands = unificationCandidates splitted
          myTrace $ "CANDIDATES:\n" ++ pretty uCands
          when suggest $ forM_ uCands $ \cs -> do
                                 putStr "-- "
                                 Text.putStrLn $ "=" `Text.intercalate` cs
          -- We unify the all candidates or only those that have been given as command-line flags.
          let unified = if autounify
                          then unifyCandidates uCands splitted
                          else splitted
          myTrace $ "UNIFIED:\n" ++ pretty unified
          -- We start by writing module header
          writeModule lang outputFilename toplevelName unified
          if test
            then do
              r <- (ExitSuccess==) <$> runModule lang outputFilename [inputFilename]
              when r $ mapM_ removeFile [inputFilename, outputFilename]
              return r
            else
              return True
    putStrLn $ "Successfully generated "      ++ show (length results) ++
               " JSON files, out of planned " ++ show count  ++ " cases."
  where
    makeInputFilename  = (<.>".json") . (stem ++) . show
    makeOutputFilename = ("output"</>) . (<.>".hs")   . (stem ++) . show
    inputFilenames     = map makeInputFilename  [1..count]
    outputFilenames    = map makeOutputFilename [1..count]
    myTrace :: String -> IO ()
    myTrace msg = debug `when` putStrLn msg
    toplevelName = capitalize $ Text.pack toplevel

main :: IO ()
main = do opts <- execParser optInfo
          generateTestJSONs opts
    where
      optInfo = info (optParser <**> helper)
        ( fullDesc
       <> progDesc "Generate a number of JSON test files, and generate type and parser for each."
       <> header   "Self-test for json-autotype" )