diff --git a/Data/Aeson/AutoType/Alternative.hs b/Data/Aeson/AutoType/Alternative.hs --- a/Data/Aeson/AutoType/Alternative.hs +++ b/Data/Aeson/AutoType/Alternative.hs @@ -21,11 +21,13 @@ toEither :: a :|: b -> Either a b toEither (AltLeft a) = Left a toEither (AltRight b) = Right b +{-# INLINE toEither #-} -- | Convert from @Either@ datatype. fromEither :: Either a b -> a :|: b fromEither (Left a) = AltLeft a fromEither (Right b) = AltRight b +{-# INLINE fromEither #-} -- | Deconstruct the type with two functions corresponding to constructors. -- This is like @either@. diff --git a/Data/Aeson/AutoType/Format.hs b/Data/Aeson/AutoType/Format.hs --- a/Data/Aeson/AutoType/Format.hs +++ b/Data/Aeson/AutoType/Format.hs @@ -68,7 +68,7 @@ -- First element of the triple is original JSON identifier, -- second element of the triple is the mapped identifier name in Haskell. -- third element of the triple shows the type in a formatted way -type MappedKey = (Text, Text, Text) +type MappedKey = (Text, Text, Text, Bool) -- | Make ToJSON declaration, given identifier (object name in Haskell) and mapping of its keys -- from JSON to Haskell identifiers *in the same order* as in *data type declaration*. @@ -83,8 +83,8 @@ makeParser identifier _ = Text.unwords [identifier, "<$>", inner] inner = " <*> " `Text.intercalate` map takeValue contents - takeValue (jsonId, _, ty) | isNullable ty = Text.concat ["v .:? \"", jsonId, "\""] - takeValue (jsonId, _, _ ) = Text.concat ["v .: \"", jsonId, "\""] + takeValue (jsonId, _, ty, True ) = Text.concat ["v .:? \"", jsonId, "\""] -- nullable types + takeValue (jsonId, _, _ , False) = Text.concat ["v .: \"", jsonId, "\""] -- Contents example for wrapFromJSON: -- " <$> --" v .: "hexValue" <*> @@ -103,7 +103,7 @@ | otherwise = ".." inner = ", " `Text.intercalate` map putValue contents - putValue (jsonId, haskellId, _typeText) = Text.unwords [escapeText jsonId, ".=", haskellId] + putValue (jsonId, haskellId, _typeText, _nullable) = Text.unwords [escapeText jsonId, ".=", haskellId] escapeText = Text.pack . show . Text.unpack -- Contents example for wrapToJSON --"hexValue" .= hexValue @@ -120,22 +120,19 @@ newDecl :: Text -> [(Text, Type)] -> DeclM Text newDecl identifier kvs = do attrs <- forM kvs $ \(k, v) -> do formatted <- formatType v - return (k, normalizeFieldName identifier k, formatted) + return (k, normalizeFieldName identifier k, formatted, isNullable v) let decl = Text.unlines [wrapDecl identifier $ fieldDecls attrs ,"" - ,makeFromJSON identifier attrs + ,makeFromJSON identifier attrs ,"" - ,makeToJSON identifier attrs] + ,makeToJSON identifier attrs] addDecl decl return identifier where fieldDecls attrList = Text.intercalate ",\n" $ map fieldDecl attrList - fieldDecl :: (Text, Text, Text) -> Text - fieldDecl (_jsonName, haskellName, fType) = Text.concat [ - " ", haskellName, " :: ", fType] - --- | Whether the type is nullable or in other words - represented by Maybe type. -isNullable = ("Maybe" `Text.isPrefixOf`) + fieldDecl :: (Text, Text, Text, Bool) -> Text + fieldDecl (_jsonName, haskellName, fType, _nullable) = Text.concat [ + " ", haskellName, " :: ", fType] addDecl decl = decls %%= (\ds -> ((), decl:ds)) @@ -161,18 +158,13 @@ escapeKeywords k | k `Set.member` keywords = k `Text.append` "_" escapeKeywords k = k -emptySetLikes :: Set Type -emptySetLikes = Set.fromList [TNull, TArray $ TUnion $ Set.fromList []] - formatType :: Type -> DeclM Text formatType TString = return "Text" formatType TNum = return "Int" formatType TBool = return "Bool" formatType (TLabel l) = return $ normalizeTypeName l -formatType (TUnion u) | uu <- u `Set.difference` emptySetLikes, - Set.size uu == 1 = do fmt <- formatType $ head $ Set.toList uu - return $ "Maybe " `Text.append` fmt --- TODO: Use Maybe (...) when nullable? +formatType (TUnion u) | (TNull==) `any` u = do fmt <- formatType $ head $ Set.toList $ Set.filter (TNull /=) u + return $ Text.concat ["Maybe (", fmt, ")"] formatType (TUnion u) = do tys <- forM (Set.toList u) formatType return $ mkUnion tys where @@ -189,7 +181,7 @@ formatType t = return $ "ERROR: Don't know how to handle: " `Text.append` tShow t emptyTypeRepr :: Text -emptyTypeRepr = "Maybe Text" -- default... +emptyTypeRepr = "Maybe Value" -- default, accepts future extension where we found no data runDecl :: DeclM a -> Text runDecl decl = Text.unlines $ finalState ^. decls diff --git a/Data/Aeson/AutoType/Pretty.hs b/Data/Aeson/AutoType/Pretty.hs --- a/Data/Aeson/AutoType/Pretty.hs +++ b/Data/Aeson/AutoType/Pretty.hs @@ -1,5 +1,9 @@ -{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, OverloadedStrings #-} -{-# LANGUAGE DeriveGeneric, StandaloneDeriving, ViewPatterns #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Instances of @Text.PrettyPrint.Out@ class to visualize diff --git a/Data/Aeson/AutoType/Test.hs b/Data/Aeson/AutoType/Test.hs --- a/Data/Aeson/AutoType/Test.hs +++ b/Data/Aeson/AutoType/Test.hs @@ -1,9 +1,12 @@ -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} -- | Arbitrary instances for the JSON @Value@. module Data.Aeson.AutoType.Test ( arbitraryTopValue ) where +import Data.Aeson.AutoType.Pretty () -- Generic instance for Value + import Control.Applicative ((<$>), (<*>)) import Data.Aeson import Data.Function (on) @@ -14,9 +17,11 @@ import Data.Text (Text) import qualified Data.Vector as V import qualified Data.HashMap.Strict as Map +import GHC.Generics import Test.QuickCheck.Arbitrary import Test.QuickCheck +import Test.SmallCheck.Series instance Arbitrary Text where arbitrary = Text.pack <$> sized (`vectorOf` alphabetic) @@ -28,15 +33,18 @@ instance (Arbitrary v) => Arbitrary (Map.HashMap Text v) where arbitrary = makeMap <$> arbitrary - where - makeMap = Map.fromList - . nubBy ((==) `on` fst) - . sortBy (compare `on` fst) +-- | Helper function for generating Arbitrary and Series instances +-- for @Data.HashMap.Strict.Map@ from lists of pairs. +makeMap = Map.fromList + . nubBy ((==) `on` fst) + . sortBy (compare `on` fst) + instance Arbitrary Scientific where arbitrary = scientific <$> arbitrary <*> arbitrary -- TODO: top value has to be complex: Object or Array +-- TODO: how to accumulate cost when generating the series? instance Arbitrary Value where arbitrary = sized arb where @@ -61,5 +69,21 @@ -- | Arbitrary JSON (must start with Object or Array.) arbitraryTopValue :: Gen Value -arbitraryTopValue = sized $ oneof . complexGens +arbitraryTopValue = sized $ oneof . complexGens + +-- * SmallCheck Serial instances +instance Monad m => Serial m Text where + series = newtypeCons Text.pack + +instance Monad m => Serial m Scientific where + series = cons2 scientific + +instance Serial m a => Serial m (V.Vector a) where + series = newtypeCons V.fromList + +instance Serial m v => Serial m (Map.HashMap Text v) where + series = newtypeCons makeMap + +-- This one is generated with Generics and instances above +instance Monad m => Serial m Value diff --git a/Data/Aeson/AutoType/Type.hs b/Data/Aeson/AutoType/Type.hs --- a/Data/Aeson/AutoType/Type.hs +++ b/Data/Aeson/AutoType/Type.hs @@ -6,12 +6,16 @@ Type(..), emptyType, isSimple, isArray, isObject, typeAsSet, hasNonTopTObj, - hasTObj) where + hasTObj, + isNullable, + emptySetLikes) where +import Prelude hiding (any) import qualified Data.HashMap.Strict as Hash import qualified Data.Set as Set import Data.Data (Data(..)) import Data.Typeable (Typeable) +import Data.Foldable (any) import Data.Text (Text) import Data.Set (Set ) import Data.HashMap.Strict(HashMap) @@ -97,33 +101,53 @@ typeSize (TUnion u) = (1+) . sum . (0:) . map typeSize . Set.toList $ u typeSize (TLabel _) = error "Don't know how to compute typeSize of TLabel." +-- | Check if this is nullable (Maybe) type, or not. +-- Nullable type will always accept TNull or missing key that contains it. +isNullable :: Type -> Bool +isNullable TNull = True +isNullable (TUnion u) = isNullable `any` u +isNullable other = False + +-- | "Null-ish" types +emptySetLikes :: Set Type +emptySetLikes = Set.fromList [TNull, TArray $ TUnion $ Set.fromList []] +-- Q: and TObj $ Map.fromList []? +{-# INLINE emptySetLikes #-} + +-- | Convert any type into union type (even if just singleton). typeAsSet :: Type -> Set Type typeAsSet (TUnion s) = s typeAsSet t = Set.singleton t -hasTObj, hasNonTopTObj, isArray, isUnion, isSimple, isObject :: Type -> Bool -- | Is the top-level constructor a TObj? +isObject :: Type -> Bool isObject (TObj _) = True isObject _ = False -- | Is it a simple (non-compound) Type? +isSimple :: Type -> Bool isSimple x = not (isObject x) && not (isArray x) && not (isUnion x) -- | Is the top-level constructor a TUnion? +isUnion :: Type -> Bool isUnion (TUnion _) = True isUnion _ = False -- | Is the top-level constructor a TArray? +-- | Check if the given type has non-top TObj. +isArray :: Type -> Bool isArray (TArray _) = True isArray _ = False +-- | Check if the given type has non-top TObj. +hasNonTopTObj :: Type -> Bool hasNonTopTObj (TObj o) = any hasTObj $ Hash.elems $ unDict o hasNonTopTObj _ = False +-- | Check if the given type has TObj on top or within array.. +hasTObj :: Type -> Bool hasTObj (TObj _) = True hasTObj (TArray a) = hasTObj a -hasTObj (TUnion u) = setAny u - where - setAny = Set.foldr ((||) . hasTObj) False +hasTObj (TUnion u) = any hasTObj u hasTObj _ = False diff --git a/GenerateTestJSON.hs b/GenerateTestJSON.hs --- a/GenerateTestJSON.hs +++ b/GenerateTestJSON.hs @@ -5,10 +5,12 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ViewPatterns #-} {-# 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(..)) @@ -18,6 +20,7 @@ import Control.Monad (forM_, forM, when) import qualified Data.ByteString.Lazy.Char8 as BSL import qualified Data.HashMap.Strict as Map +import qualified Data.Set as Set import Data.Aeson import Data.Function (on) import Data.List @@ -83,43 +86,81 @@ 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 = fst $ filterM checkDup list `runState` 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 :: IO () generateTestJSONs = do - results <- forM (zip inputFilenames outputFilenames) $ \(inputFilename, outputFilename) -> do - jsonValue :: Value <- generate $ resize flags_size arbitraryTopValue - BSL.writeFile inputFilename $ encode jsonValue - -- Read type from each file - typeForEachFile <- catMaybes <$> mapM extractTypeFromJSONFile [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 "TopLevel" finalType - --myTrace $ "SPLITTED: " ++ pretty splitted - assertM $ not $ any hasNonTopTObj $ Map.elems splitted - -- We compute which type labels are candidates for unification - let uCands = unificationCandidates splitted - myTrace $ "CANDIDATES:\n" ++ pretty uCands - when flags_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 flags_autounify - then unifyCandidates uCands splitted - else splitted - myTrace $ "UNIFIED:\n" ++ pretty unified - -- We start by writing module header - writeHaskellModule outputFilename unified - if flags_test - then do - r <- (==ExitSuccess) <$> system (unwords $ ["runghc", outputFilename] ++ inputFilenames) - when r $ mapM_ removeFile [inputFilename, outputFilename] - return r - else - return True + testValues :: [Value] <- generate $ + resize flags_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 [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 "TopLevel" finalType + --myTrace $ "SPLITTED: " ++ pretty splitted + assertM $ not $ any hasNonTopTObj $ Map.elems splitted + -- We compute which type labels are candidates for unification + let uCands = unificationCandidates splitted + myTrace $ "CANDIDATES:\n" ++ pretty uCands + when flags_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 flags_autounify + then unifyCandidates uCands splitted + else splitted + myTrace $ "UNIFIED:\n" ++ pretty unified + -- We start by writing module header + writeHaskellModule outputFilename unified + if flags_test + then do + r <- (==ExitSuccess) <$> system (unwords $ ["runghc", outputFilename] ++ inputFilenames) + when r $ mapM_ removeFile [inputFilename, outputFilename] + return r + else + return True putStrLn $ "Successfully generated " ++ show (length results) ++ " JSON files, out of planned " ++ show flags_count ++ " cases." where diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,7 +4,7 @@ Parser and printer instances are derived using [Aeson](http://hackage.haskell.org/package/aeson). -The program uses union type unification to trim output declarations. The types of same attribute tag and similar attribute set, are automatically unified using recognition by attribute set matching. (This option can be optionally turned off, or a set of unified types may be given explicitly.) `Either` alternatives is used to assure that all `JSON` inputs seen in example input file are handled correctly. +The program uses union type unification to trim output declarations. The types of same attribute tag and similar attribute set, are automatically unified using recognition by attribute set matching. (This option can be optionally turned off, or a set of unified types may be given explicitly.) `:|:` alternatives (similar to `Either`) are used to assure that all `JSON` inputs seen in example input file are handled correctly. I should probably write a short paper to explain the methodology. @@ -92,7 +92,7 @@ ``` data Parameter = Parameter { - parameterParameterValue :: Either Bool (Either Int Text), + parameterParameterValue :: Bool :|: Int :|: Text, parameterParameterName :: Text } diff --git a/TestQC.hs b/TestQC.hs --- a/TestQC.hs +++ b/TestQC.hs @@ -3,13 +3,15 @@ main ) where -import Test.QuickCheck ---import Test.QuickCheck.Arbitrary - +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 @@ -23,8 +25,16 @@ prop_valueTypeSizeAndTypeSize :: Value -> Bool prop_valueTypeSizeAndTypeSize v = valueTypeSize v >= typeSize (extractType v) -} +-- | Maximum reasonable depth for quick testing +depth = 5 + main :: IO () -main = quickCheck prop_typeCheck - {- prop_typeSize, - prop_valueAndValueTypeSize, - prop_valueTypeSizeAndTypeSize]-} +main = do smallCheck depth prop_typeCheck + quickCheckWith myArgs prop_typeCheck + {- prop_typeSize, + prop_valueAndValueTypeSize, + prop_valueTypeSizeAndTypeSize]-} + 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,10 @@ Changelog ========= + 0.3 Apr 2015 + + * Passed all smallcheck/quickcheck tests. + * Approaching release candidate. + 0.2.5.13 Apr 2015 * Correctly handling lone option, not yet union with optionality. 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: 0.2.5.13 +version: 0.3 synopsis: Automatic type declaration for JSON input data description: Generates datatype declarations with Aeson's "FromJSON" instances from a set of example ".json" files. @@ -137,6 +137,7 @@ pretty >=1.1 && <1.3, process >=1.1 && <1.4, 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, @@ -146,7 +147,8 @@ default-language: Haskell2010 -- test suite with QuickCheck -executable json-autotype-qc-test +test-suite json-autotype-qc-test + type: exitcode-stdio-1.0 main-is: TestQC.hs other-modules: Data.Aeson.AutoType.Util, Data.Aeson.AutoType.Test, @@ -172,6 +174,7 @@ pretty >=1.1 && <1.3, process >=1.1 && <1.4, 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,