diff --git a/CommonCLI.hs b/CommonCLI.hs --- a/CommonCLI.hs +++ b/CommonCLI.hs @@ -1,7 +1,10 @@ -module CommonCLI(TypeOpts(..), unflag, tyOptParser) where +module CommonCLI(TypeOpts(..), unflag, tyOptParser, runghc) where -import Data.Monoid((<>)) -import Options.Applicative +import Data.Monoid ((<>)) +import Options.Applicative +import System.Process (system) +import qualified System.Environment (lookupEnv) +import System.Exit (ExitCode) data TypeOpts = TyOptions { autounify :: Bool @@ -19,4 +22,13 @@ <*> switch (long "debug" <> help "Set this flag to see more debugging info" ) <*> unflag (long "no-test" <> help "Do not run generated parser afterwards" ) <*> unflag (long "no-suggest" <> help "Do not suggest candidates for unification" ) + +runghc :: [String] -> IO ExitCode +runghc arguments = do + maybeStack <- System.Environment.lookupEnv "STACK_EXEC" + maybeCabal <- System.Environment.lookupEnv "CABAL_SANDBOX_CONFIG" + let execPrefix | Just stackExec <- maybeStack = [stackExec, "exec", "--"] + | Just cabalConfig <- maybeCabal = ["cabal", "exec", "--"] + | otherwise = [] + system (unwords $ execPrefix ++ ["runghc"] ++ arguments) diff --git a/GenerateJSONParser.hs b/GenerateJSONParser.hs --- a/GenerateJSONParser.hs +++ b/GenerateJSONParser.hs @@ -1,8 +1,5 @@ --- {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} --- {-# LANGUAGE DeriveGeneric #-} --- {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Main where @@ -19,7 +16,7 @@ import System.Process (system) import qualified Data.ByteString.Lazy.Char8 as BSL import qualified Data.HashMap.Strict as Map -import Data.Aeson --(Value(..), decode, encode, FromJSON(..), ToJSON(..)) +import Data.Aeson(Value(..), decode, encode, FromJSON(..), ToJSON(..)) import qualified Data.Text as Text import qualified Data.Text.IO as Text import Data.Text (Text) @@ -59,7 +56,7 @@ optParser :: Parser Options optParser = Options <$> tyOptParser - <*> strOption (short 'o' <> long "output" <> value defaultOutputFilename) + <*> strOption (short 'o' <> long "output" <> long "outputFilename" <> value defaultOutputFilename) <*> unflag (short 'n' <> long "no-typecheck" <> help "Do not typecheck after unification") <*> switch (long "yaml" <> help "Parse inputs as YAML instead of JSON" ) <*> switch (short 'p' <> long "preprocessor" <> help "Work as GHC preprocessor (and skip preprocessor pragma)" ) @@ -153,7 +150,7 @@ -- We start by writing module header writeHaskellModule outputFilename unified when (test $ tyOpts opts) $ - exitWith =<< system (unwords $ ["runghc", "-package=aeson", outputFilename] ++ passedTypeCheck) + exitWith =<< runghc (outputFilename:passedTypeCheck) where -- | Works like @Debug.trace@ when the --debug flag is enabled, and does nothing otherwise. myTrace :: String -> IO () diff --git a/GenerateTestJSON.hs b/GenerateTestJSON.hs --- a/GenerateTestJSON.hs +++ b/GenerateTestJSON.hs @@ -23,7 +23,7 @@ import qualified Data.HashMap.Strict as Map import qualified Data.Set as Set import Data.Monoid ((<>)) -import Data.Aeson +import Data.Aeson (Value(..), decode, encode, FromJSON(..), ToJSON(..)) import Data.Function (on) import Data.List import qualified Data.Text as Text @@ -174,7 +174,7 @@ writeHaskellModule outputFilename unified if test then do - r <- (==ExitSuccess) <$> system (unwords ["runghc", "-package=aeson", outputFilename, inputFilename]) + r <- (==ExitSuccess) <$> runghc [outputFilename, inputFilename] when r $ mapM_ removeFile [inputFilename, outputFilename] return r else diff --git a/TestQC.hs b/TestQC.hs deleted file mode 100644 --- a/TestQC.hs +++ /dev/null @@ -1,28 +0,0 @@ --- | QuickCheck instances for automatically generating JSON inputs, --- and checking that json-autotype works correctly on these. -module Main( - main - ) where - -import Control.Monad -import Data.Aeson -import Data.Aeson.AutoType.Extract -import Data.Aeson.AutoType.Test() -- Arbitrary instance for Value - -import Test.QuickCheck -import Test.SmallCheck ---import Test.QuickCheck.Arbitrary - -prop_typeCheck :: Value -> Bool -prop_typeCheck v = v `typeCheck` extractType v - --- | Maximum reasonable depth for quick exhaustive testing -depth = 5 - -main :: IO () -main = do smallCheck depth prop_typeCheck - quickCheckWith myArgs prop_typeCheck - where - -- 17 - reasonable size for runghc - --myArgs i = stdArgs { maxSize=i } - myArgs = stdArgs { maxSize=17, maxSuccess=1000 } diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,9 @@ Changelog ========= + 1.0.18 Nov 2017 + * Fixed unit tests. + * Fixed import for inclusion in Stackage. + 1.0.17 Nov 2017 * Fixed build and test issues. diff --git a/json-autotype.cabal b/json-autotype.cabal --- a/json-autotype.cabal +++ b/json-autotype.cabal @@ -1,6 +1,6 @@ -- Build information for the package. name: json-autotype -version: 1.0.17 +version: 1.0.18 synopsis: Automatic type declaration for JSON input data description: Generates datatype declarations with Aeson's "FromJSON" instances from a set of example ".json" files. @@ -68,7 +68,7 @@ filepath >=1.3 && <1.5, hashable >=1.2 && <1.3, ---hint >=0.4 && <0.6, - optparse-applicative >=0.13 && <1.0, + optparse-applicative >=0.11 && <1.0, lens >=4.1 && <4.16, --mmap >=0.5 && <0.6, mtl >=2.1 && <2.3, @@ -101,7 +101,7 @@ DeriveDataTypeable, DeriveGeneric, RecordWildCards - build-depends: base >=4.3 && <4.10, + build-depends: base >=4.3 && <4.11, GenericPretty >=1.2 && <1.3, aeson >=0.7 && <1.3, bytestring >=0.9 && <0.11, @@ -111,7 +111,7 @@ --hint >=0.4 && <0.6, lens >=4.1 && <4.16, mtl >=2.1 && <2.3, - optparse-applicative >=0.13 && <1.0, + optparse-applicative >=0.12 && <1.0, pretty >=1.1 && <1.3, process >=1.1 && <1.7, scientific >=0.3 && <0.5, @@ -128,7 +128,7 @@ -- and extracted types. test-suite json-autotype-qc-test type: exitcode-stdio-1.0 - main-is: TestQC.hs + main-is: test/TestQC.hs other-modules: Data.Aeson.AutoType.Util Data.Aeson.AutoType.Extract Data.Aeson.AutoType.Test @@ -142,7 +142,7 @@ DeriveDataTypeable, DeriveGeneric, RecordWildCards - build-depends: base >=4.3 && <4.10, + build-depends: base >=4.3 && <4.11, GenericPretty >=1.2 && <1.3, aeson >=0.7 && <1.3, bytestring >=0.9 && <0.11, @@ -164,6 +164,46 @@ -- hs-source-dirs: default-language: Haskell2010 +test-suite json-autotype-examples + type: exitcode-stdio-1.0 + main-is: test/TestExamples.hs + other-modules: Data.Aeson.AutoType.Util + Data.Aeson.AutoType.Extract + Data.Aeson.AutoType.Test + Data.Aeson.AutoType.Type + Data.Aeson.AutoType.Pretty + CommonCLI + other-extensions: TemplateHaskell, + ScopedTypeVariables, + OverloadedStrings, + FlexibleInstances, + MultiParamTypeClasses, + DeriveDataTypeable, + DeriveGeneric, + RecordWildCards + build-depends: base >=4.3 && <4.11, + GenericPretty >=1.2 && <1.3, + aeson >=0.7 && <1.3, + bytestring >=0.9 && <0.11, + containers >=0.3 && <0.6, + directory >=1.1 && <1.4, + filepath >=1.3 && <1.5, + hashable >=1.2 && <1.3, + lens >=4.1 && <4.16, + mtl >=2.1 && <2.3, + optparse-applicative >=0.11 && <1.0, + pretty >=1.1 && <1.3, + process >=1.1 && <1.7, + scientific >=0.3 && <0.5, + smallcheck >=1.0 && <1.2, + text >=1.1 && <1.4, + uniplate >=1.6 && <1.7, + unordered-containers >=0.2 && <0.3, + vector >=0.9 && <0.13, + QuickCheck >=2.4 && <3.0 + -- hs-source-dirs: + default-language: Haskell2010 + -- Test suite with Haskell code generation and compilation test-suite json-autotype-gen-test type: exitcode-stdio-1.0 @@ -184,7 +224,7 @@ DeriveDataTypeable, DeriveGeneric, RecordWildCards - build-depends: base >=4.3 && <4.10, + build-depends: base >=4.3 && <4.11, GenericPretty >=1.2 && <1.3, aeson >=0.7 && <1.3, bytestring >=0.9 && <0.11, @@ -192,7 +232,7 @@ directory >=1.1 && <1.4, filepath >=1.3 && <1.5, hashable >=1.2 && <1.3, - optparse-applicative >=0.13 && <1.0, + optparse-applicative >=0.12 && <1.0, lens >=4.1 && <4.16, mtl >=2.1 && <2.3, pretty >=1.1 && <1.3, diff --git a/test/TestExamples.hs b/test/TestExamples.hs new file mode 100644 --- /dev/null +++ b/test/TestExamples.hs @@ -0,0 +1,54 @@ +-- Test over all files in examples/ directory +module Main(main) where + +import Control.Monad(forM) +import Data.Char(toUpper) +import Data.Functor ((<$>)) +import Data.List(isPrefixOf, isSuffixOf) +import System.Directory(doesDirectoryExist, getDirectoryContents) +import System.FilePath(dropExtension, (), (<.>)) +import System.Exit(exitSuccess, exitWith, ExitCode(..)) + +import CommonCLI + +-- | +getRecursiveContents :: FilePath -> IO [FilePath] +getRecursiveContents topdir = do + ex<-doesDirectoryExist topdir + if ex + then do + names <- getDirectoryContents topdir + let properNames = filter (not . isPrefixOf ".") names + paths <- forM properNames $ \name -> do + let path = topdir name + isDirectory <- doesDirectoryExist path + if isDirectory + then getRecursiveContents path + else return [path] + return (concat paths) + else return [] + +capitalize :: String -> String +capitalize (s:ss) = toUpper s:ss + +main :: IO () +main = do + filenames <- filter (isSuffixOf ".json") + <$> getRecursiveContents "examples" + results <- forM filenames $ \filename -> do + let outputFilename = capitalize (dropExtension filename) <.> "hs" + genResult <- runghc ["GenerateJSONParser.hs", filename, "--outputFilename", outputFilename] + return 0 + if genResult == ExitSuccess + then return 0 -- number of failures so far + else do + parserResult <- runghc [outputFilename, filename] + if parserResult == ExitSuccess + then return 0 + else return 1 + exitCode $ sum results + +exitCode :: Int -> IO () +exitCode 0 = exitSuccess +exitCode n = exitWith $ ExitFailure n + diff --git a/test/TestQC.hs b/test/TestQC.hs new file mode 100644 --- /dev/null +++ b/test/TestQC.hs @@ -0,0 +1,28 @@ +-- | QuickCheck instances for automatically generating JSON inputs, +-- and checking that json-autotype works correctly on these. +module Main( + main + ) where + +import Control.Monad +import Data.Aeson +import Data.Aeson.AutoType.Extract +import Data.Aeson.AutoType.Test() -- Arbitrary instance for Value + +import Test.QuickCheck +import Test.SmallCheck +--import Test.QuickCheck.Arbitrary + +prop_typeCheck :: Value -> Bool +prop_typeCheck v = v `typeCheck` extractType v + +-- | Maximum reasonable depth for quick exhaustive testing +depth = 5 + +main :: IO () +main = do smallCheck depth prop_typeCheck + quickCheckWith myArgs prop_typeCheck + where + -- 17 - reasonable size for runghc + --myArgs i = stdArgs { maxSize=i } + myArgs = stdArgs { maxSize=17, maxSuccess=1000 }