json-autotype 0.2.5.11 → 0.2.5.12
raw patch · 12 files changed
+486/−90 lines, 12 filesdep +QuickCheckdep +directorydep ~hflagsdep ~hintdep ~lensnew-component:exe:json-autotype-qc-testnew-component:exe:json-autotype-random-testPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: QuickCheck, directory
Dependency ranges changed: hflags, hint, lens, process
API changes (from Hackage documentation)
- Data.Aeson.AutoType.Extract: typeSize :: Type -> Int
+ Data.Aeson.AutoType.Extract: typeCheck :: Value -> Type -> Bool
Files
- Data/Aeson/AutoType/Alternative.hs +8/−0
- Data/Aeson/AutoType/CodeGen.hs +6/−5
- Data/Aeson/AutoType/Extract.hs +70/−40
- Data/Aeson/AutoType/Format.hs +40/−22
- Data/Aeson/AutoType/Test.hs +65/−0
- Data/Aeson/AutoType/Type.hs +5/−5
- Data/Aeson/AutoType/Util.hs +5/−2
- GenerateJSONParser.hs +34/−7
- GenerateTestJSON.hs +137/−0
- TestQC.hs +30/−0
- changelog.md +6/−0
- json-autotype.cabal +80/−9
Data/Aeson/AutoType/Alternative.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE TypeOperators #-}+-- | This module defines data type (a :|: b) that behaves all like @Either@,+-- except that has no tag in JSON representation as used by @FromJSON@ and @ToJSON@. module Data.Aeson.AutoType.Alternative( (:|:)(..) , toEither, fromEither@@ -8,19 +10,25 @@ import Data.Aeson import Control.Applicative +-- | Data type (a :|: b) that behaves all like @Either@,+-- except that has no tag in JSON representation as used by @FromJSON@ and @ToJSON@. data a :|: b = AltLeft a | AltRight b deriving(Show,Eq,Ord) infixr 5 :|: +-- | Convert to @Either@ datatype. toEither :: a :|: b -> Either a b toEither (AltLeft a) = Left a toEither (AltRight b) = Right b +-- | Convert from @Either@ datatype. fromEither :: Either a b -> a :|: b fromEither (Left a) = AltLeft a fromEither (Right b) = AltRight b +-- | Deconstruct the type with two functions corresponding to constructors.+-- This is like @either@. alt :: (a -> c) -> (b -> c) -> a :|: b -> c alt f _ (AltLeft a) = f a alt _ g (AltRight b) = g b
Data/Aeson/AutoType/CodeGen.hs view
@@ -57,17 +57,18 @@ ," case decode input of" ," Nothing -> fatal $ case (decode input :: Maybe Value) of" ," Nothing -> \"Invalid JSON file: \" ++ filename"- ," Just v -> \"Mismatched JSON value: \" ++ show v"- ," Just r -> return r"+ ," Just v -> \"Mismatched JSON value from file: \" ++ filename"+ ," Just r -> return (r :: TopLevel)" ," where" ," fatal :: String -> IO a" ," fatal msg = do hPutStrLn stderr msg" ," exitFailure" ,"" ,"main :: IO ()"- ,"main = do filenames <- getArgs"- ," forM_ filenames (\\f -> parse f >>= print)"- ," exitSuccess"+ ,"main = do"+ ," filenames <- getArgs"+ ," forM_ filenames (\\f -> parse f >>= (\\p -> p `seq` putStrLn $ \"Successfully parsed \" ++ f))"+ ," exitSuccess" ,""] -- | Write a Haskell module to an output file, or stdout if `-` filename is given.
Data/Aeson/AutoType/Extract.hs view
@@ -1,20 +1,23 @@ -- | Extraction and unification of AutoType's @Type@ from Aeson @Value@.-module Data.Aeson.AutoType.Extract(valueSize, typeSize, valueTypeSize,+module Data.Aeson.AutoType.Extract(valueSize, valueTypeSize, valueDepth, Dict(..), Type(..), emptyType,- extractType, unifyTypes) where+ extractType, unifyTypes,+ typeCheck) where -import Control.Exception (assert)+import Control.Exception (assert) import Data.Aeson.AutoType.Type-import qualified Data.HashMap.Strict as Hash-import qualified Data.Set as Set-import qualified Data.Vector as V---import Data.Typeable (Typeable)+import qualified Data.HashMap.Strict as Map+import Data.HashMap.Strict (HashMap)+import qualified Data.Set as Set+import qualified Data.Vector as V import Data.Aeson-import Data.Text (Text)-import Data.Set (Set )-import Data.List (foldl1')+import Data.Text (Text)+import Data.Set (Set )+import Data.List (foldl1') +--import Debug.Trace+ -- | Compute total number of nodes (and leaves) within the value tree. -- Each simple JavaScript type (including String) is counted as of size 1, -- whereas both Array or object types are counted as 1+sum of the sizes@@ -25,7 +28,7 @@ valueSize (Number _) = 1 valueSize (String _) = 1 valueSize (Array a) = V.foldl' (+) 1 $ V.map valueSize a-valueSize (Object o) = (1+) . sum . map valueSize . Hash.elems $ o+valueSize (Object o) = (1+) . sum . map valueSize . Map.elems $ o -- | Compute total size of the type of the @Value@. -- For:@@ -39,7 +42,7 @@ valueTypeSize (Number _) = 1 valueTypeSize (String _) = 1 valueTypeSize (Array a) = (1+) . V.foldl' max 0 $ V.map valueTypeSize a-valueTypeSize (Object o) = (1+) . sum . map valueTypeSize . Hash.elems $ o+valueTypeSize (Object o) = (1+) . sum . map valueTypeSize . Map.elems $ o -- | Compute total depth of the value. -- For:@@ -51,42 +54,66 @@ valueDepth (Number _) = 1 valueDepth (String _) = 1 valueDepth (Array a) = (1+) . V.foldl' max 0 $ V.map valueDepth a-valueDepth (Object o) = (1+) . maximum . (0:) . map valueDepth . Hash.elems $ o+valueDepth (Object o) = (1+) . maximum . (0:) . map valueDepth . Map.elems $ o -- | Extract @Type@ from the JSON @Value@. -- Unifying types of array elements, if necessary.-extractType :: Value -> Type-extractType (Object o) = TObj $ Dict $ Hash.map extractType o+extractType :: Value -> Type+extractType (Object o) = TObj $ Dict $ Map.map extractType o extractType Null = TNull extractType (Bool _) = TBool extractType (Number _) = TNum extractType (String _) = TString-extractType (Array a) | V.null a = TArray emptyType-extractType (Array a) = TArray $ V.foldl1' unifyTypes $ V.map extractType a+extractType (Array a) | V.null a = TArray emptyType+extractType (Array a) = TArray $ V.foldl1' unifyTypes $ traceShow $ V.map extractType a+ where+ --traceShow a = trace (show a) a+ traceShow a = a +-- | Type check the value with the derived type.+typeCheck :: Value -> Type -> Bool+typeCheck Null TNull = True+typeCheck v (TUnion u) = typeCheck v `any` Set.toList u+typeCheck (Bool _) TBool = True+typeCheck (Number _) TNum = True+typeCheck (String _) TString = True+typeCheck (Array elts) (TArray eltType) = (`typeCheck` eltType) `all` V.toList elts+typeCheck (Object d) (TObj e ) = typeCheckKey `all` keysOfBoth+ where+ typeCheckKey k = getValue k d `typeCheck` get k e+ getValue :: Text -> HashMap Text Value -> Value+ getValue = Map.lookupDefault Null+ keysOfBoth :: [Text]+ keysOfBoth = Set.toList $ Set.fromList (Map.keys d) `Set.union` keys e+typeCheck _ (TLabel _ ) = error "Cannot typecheck labels without environment!"+typeCheck a b = {-trace msg $-} False+ where+ msg = "Mismatch: " ++ show a ++ " :: " ++ show b++d `allKeys` e = Set.toList (keys d `Set.union` keys e)+ -- | Standard unification procedure on @Type@s, -- with inclusion of @Type@ unions. unifyTypes :: Type -> Type -> Type-unifyTypes TBool TBool = TBool-unifyTypes TNum TNum = TNum-unifyTypes TString TString = TString-unifyTypes TNull TNull = TNull-unifyTypes (TObj d) (TObj e) = TObj newDict +unifyTypes TBool TBool = TBool+unifyTypes TNum TNum = TNum+unifyTypes TString TString = TString+unifyTypes TNull TNull = TNull+unifyTypes (TObj d) (TObj e) = TObj newDict where newDict :: Dict- newDict = Dict $ Hash.fromList [(k, get k d `unifyTypes`- get k e) | k <- allKeys ]- allKeys :: [Text]- allKeys = Set.toList (keys d `Set.union` keys e)-unifyTypes (TArray u) (TArray v) = TArray $ u `unifyTypes` v-unifyTypes t s = typeAsSet t `unifyUnion` typeAsSet s+ newDict = Dict $ Map.fromList [(k, get k d `unifyTypes`+ get k e) | k <- allKeys d e ]+unifyTypes (TArray u) (TArray v) = TArray $ u `unifyTypes` v+unifyTypes t s = typeAsSet t `unifyUnion` typeAsSet s -- | Unify sets of types (sets are union types of alternatives). unifyUnion :: Set Type -> Set Type -> Type unifyUnion u v = assertions $- union $ uSimple `Set.union`- vSimple `Set.union`- oset+ union $ uSimple `Set.union`+ vSimple `Set.union`+ unifiedObjects `Set.union`+ Set.singleton unifiedArray where -- We partition our types for easier unification into simple and compound (uSimple, uCompound) = Set.partition isSimple u@@ -96,16 +123,19 @@ -- then we partition compound typs into objects and arrays. -- Note that there should be no TUnion here, since we are inside a TUnion already. -- (That is reduced by @union@ smart costructor as superfluous.)- (uObj, uArr) = Set.partition isObject uCompound- (vObj, vArr) = Set.partition isObject vCompound- oset = Set.fromList $ if null objects- then []- else [foldl1' unifyTypes objects]+ (uObj, uArr) = Set.partition isObject uCompound+ (vObj, vArr) = Set.partition isObject vCompound+ unifiedObjects = Set.fromList $ if null objects+ then []+ else [foldl1' unifyTypes objects] objects = Set.toList $ uObj `Set.union` vObj- {-aset = Set.fromList $ if null arrays- then []- else [foldl1' unifyTypes arrays]-}- --arrays = Set.toList $ uArr `Set.union` vArr+ arrayElts :: [Type]+ arrayElts = map (\(TArray ty) -> ty) $+ Set.toList $+ uArr `Set.union` vArr+ unifiedArray = TArray $ if null arrayElts+ then emptyType+ else foldl1' unifyTypes arrayElts -- | Smart constructor for union types. union :: Set Type -> Type
Data/Aeson/AutoType/Format.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGuaGE DeriveGeneric #-}+{-# LANGuaGE FlexibleContexts #-} module Data.Aeson.AutoType.Format( displaySplitTypes, splitTypeByLabel, unificationCandidates, unifyCandidates@@ -29,6 +30,9 @@ import Data.Aeson.AutoType.Extract import Data.Aeson.AutoType.Util () +--import Debug.Trace -- DEBUG+trace _ x = x+ fst3 :: (t, t1, t2) -> t fst3 (a, _b, _c) = a @@ -49,6 +53,11 @@ tShow :: (Show a) => a -> Text tShow = Text.pack . show +-- | Wrap a type alias.+wrapAlias :: Text -> Text -> Text+wrapAlias identifier contents = Text.unwords ["type", identifier, "=", contents]++-- | Wrap a data type declaration wrapDecl :: Text -> Text -> Text wrapDecl identifier contents = Text.unlines [header, contents, " } deriving (Show,Eq,Generic)"] --,"\nderiveJSON defaultOptions ''" `Text.append` identifier]@@ -66,14 +75,13 @@ makeFromJSON identifier contents = Text.unlines [ Text.unwords ["instance FromJSON", identifier, "where"]- , Text.unwords [" parseJSON (Object v) =", identifier, inner]+ , Text.unwords [" parseJSON (Object v) =", makeParser identifier contents] , " parseJSON _ = mzero" ] where- inner = if Text.null inner'- then ""- else "<$>" `Text.append` inner'- inner' = Text.intercalate " <*> " $- map (takeValue . fst) contents+ makeParser identifier [] = Text.unwords ["return ", identifier]+ makeParser identifier _ = Text.unwords [identifier, "<$>", inner]+ inner = " <*> " `Text.intercalate`+ map (takeValue . fst) contents takeValue jsonId = Text.concat ["v .: \"", jsonId, "\""] -- Contents example for wrapFromJSON: -- " <$>@@ -86,9 +94,11 @@ makeToJSON identifier contents = Text.unlines [ Text.concat ["instance ToJSON ", identifier, " where"],- Text.concat [" toJSON (", identifier, " {..}) = object [", inner, "]"]+ Text.concat [" toJSON (", identifier, " {", wildcard, "}) = object [", inner, "]"] ] where+ wildcard | length contents == 0 = ""+ | otherwise = ".." inner = ", " `Text.intercalate` map putValue contents putValue (jsonId, haskellId) = Text.unwords [escapeText jsonId, ".=", haskellId]@@ -104,7 +114,7 @@ i <- stepM return $! "Obj" `Text.append` tShow i --- * Printing a single type declaration+-- * Printing a single data type declaration newDecl :: Text -> [(Text, Type)] -> DeclM Text newDecl identifier kvs = do attrs <- forM kvs $ \(k, v) -> do formatted <- formatType v@@ -115,7 +125,7 @@ ,makeFromJSON identifier fieldMapping ,"" ,makeToJSON identifier fieldMapping]- decls %%= (\ds -> ((), decl:ds))+ addDecl decl return identifier where fieldDecls attrList = Text.intercalate ",\n" $ map fieldDecl attrList@@ -123,6 +133,14 @@ fieldDecl (_jsonName, haskellName, fType) = Text.concat [ " ", haskellName, " :: ", fType] +addDecl decl = decls %%= (\ds -> ((), decl:ds))++-- | Add new type alias for Array type+newAlias :: Text -> Type -> DeclM Text+newAlias identifier content = do formatted <- formatType content+ addDecl $ Text.unlines [wrapAlias identifier formatted]+ return identifier+ -- | Convert a JSON key name given by second argument, -- from within a dictionary keyed with first argument, -- into a name of Haskell record field (hopefully distinct from other such selectors.)@@ -197,30 +215,28 @@ return (k, component) addType l (TObj $ Dict $ Map.fromList kvs) return $! TLabel l---splitTypeByLabel' l t = error $ "ERROR: Don't know how to handle: " ++ show t -- | Splits initial type with a given label, into a mapping of object type names and object type structures. splitTypeByLabel :: Text -> Type -> Map Text Type splitTypeByLabel topLabel t = Map.map (foldl1' unifyTypes) finalState where- job = splitTypeByLabel' topLabel t- -- addType topLabel r+ finalize (TLabel l) = assert (l == topLabel) $ return ()+ finalize topLevel = addType topLabel topLevel initialState = Map.empty- (_, finalState) = runState job initialState+ (_, finalState) = runState (splitTypeByLabel' topLabel t >>= finalize) initialState formatObjectType :: Text -> Type -> DeclM Text-formatObjectType identifier (TObj o) = newDecl identifier d+formatObjectType identifier (TObj o) = newDecl identifier d where d = Map.toList $ unDict o-formatObjectType _ other = formatType other+formatObjectType identifier other = newAlias identifier other displaySplitTypes :: Map Text Type -> Text-displaySplitTypes dict = runDecl declarations+displaySplitTypes dict = trace ("displaySplitTypes: " ++ show (toposort dict)) $ runDecl declarations where declarations =- forM (toposort dict) $ \(name, typ) -> do- let name' = normalizeTypeName name- formatObjectType name' typ+ forM (toposort dict) $ \(name, typ) ->+ formatObjectType (normalizeTypeName name) typ normalizeTypeName :: Text -> Text normalizeTypeName = escapeKeywords .@@ -269,14 +285,16 @@ unificationCandidates = Map.elems . Map.filter candidates . Map.fromListWith (++) .- map entry .+ concatMap entry . Map.toList where+ -- | Candidate entry has to have at least two candidates, so that unification makes sense candidates [ ] = False candidates [_] = False candidates _ = True- entry (k, TObj o) = (Set.fromList $ Map.keys $ unDict o, [k])- entry (_, other ) = error $ "Unexpected type: " ++ show other+ -- | Make a candidate entry for each object type, which points from its keys to its label.+ entry (k, TObj o) = [(Set.fromList $ Map.keys $ unDict o, [k])]+ entry _ = [] -- ignore array elements and toplevel type if it is Array -- | Unifies candidates on a give input list. unifyCandidates :: [[Text]] -> Map Text Type -> Map Text Type
+ Data/Aeson/AutoType/Test.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE FlexibleInstances #-}+-- | Arbitrary instances for the JSON @Value@.+module Data.Aeson.AutoType.Test (+ arbitraryTopValue+ ) where++import Data.Functor ((<$>))+import Data.Aeson+import Data.Function (on)+import Data.Generics.Uniplate.Data+import Data.List+import Data.Scientific+import qualified Data.Text as Text+import Data.Text (Text)+import qualified Data.Vector as V+import qualified Data.HashMap.Strict as Map++import Test.QuickCheck.Arbitrary+import Test.QuickCheck++instance Arbitrary Text where+ arbitrary = Text.pack <$> sized (`vectorOf` alphabetic)+ where+ alphabetic = choose ('a', 'z')++instance (Arbitrary a) => Arbitrary (V.Vector a) where+ arbitrary = V.fromList <$> arbitrary++instance (Arbitrary v) => Arbitrary (Map.HashMap Text v) where+ arbitrary = makeMap <$> arbitrary+ where+ 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+instance Arbitrary Value where+ arbitrary = sized arb+ where+ arb n | n < 0 = error "Negative size!"+ arb 0 = return Null+ arb 1 = oneof simpleGens+ arb i = oneof $ complexGens (i - 1) ++ simpleGens+ simpleGens = [Number <$> arbitrary+ ,Bool <$> arbitrary+ ,String <$> arbitrary]+ shrink = concatMap simpleShrink+ . universe++simpleShrink :: Value -> [Value]+simpleShrink (Array a) = map (Array . V.fromList) $ shrink $ V.toList a+simpleShrink (Object o) = map (Object . Map.fromList) $ shrink $ Map.toList o+simpleShrink _ = [] -- Nothing for simple objects++-- | Generators of compound structures: object and array.+complexGens i = [Object . Map.fromList <$> resize i arbitrary,+ Array <$> resize i arbitrary]++-- | Arbitrary JSON (must start with Object or Array.)+arbitraryTopValue :: Gen Value+arbitraryTopValue = sized $ oneof . complexGens+
Data/Aeson/AutoType/Type.hs view
@@ -52,9 +52,9 @@ -- * Type data Type = TNull | TBool | TNum | TString | TUnion (Set Type) |- TLabel Text |- TObj Dict |- TArray Type+ TLabel Text |+ TObj Dict |+ TArray Type deriving (Show,Eq, Ord, Data, Typeable, Generic) instance Out Type@@ -82,7 +82,7 @@ -- | Lookup the Type within the dictionary. get :: Text -> Dict -> Type-get key = Hash.lookupDefault emptyType key . unDict +get key = Hash.lookupDefault TNull key . unDict -- $derive makeUniplateDirect ''Type @@ -94,7 +94,7 @@ typeSize TString = 1 typeSize (TObj o) = (1+) . sum . map typeSize . Hash.elems . unDict $ o typeSize (TArray a) = 1 + typeSize a-typeSize (TUnion u) = (1+) . maximum . (0:) . map typeSize . Set.toList $ u+typeSize (TUnion u) = (1+) . sum . (0:) . map typeSize . Set.toList $ u typeSize (TLabel _) = error "Don't know how to compute typeSize of TLabel." typeAsSet :: Type -> Set Type
Data/Aeson/AutoType/Util.hs view
@@ -1,3 +1,4 @@+-- | Utility functions that may be ultimately moved to some library. module Data.Aeson.AutoType.Util( withFileOrHandle , withFileOrDefaultHandle , assertM ) where@@ -15,6 +16,9 @@ withFileOrHandle "-" _ handle action = action handle withFileOrHandle name ioMode _ action = withFile name ioMode action +-- | Generic function for choosing either file with given name or stdin/stdout as input/output.+-- It accepts the function that takes the corresponding handle.+-- Stdin/stdout is selected by "-". withFileOrDefaultHandle :: FilePath -> IOMode -> (Handle -> IO r) -> IO r withFileOrDefaultHandle "-" ReadMode action = action stdin withFileOrDefaultHandle "-" WriteMode action = action stdout@@ -23,10 +27,9 @@ ++ ") for `-` in withFileOrDefaultHandle." withFileOrDefaultHandle filename ioMode action = withFile filename ioMode action -+-- | Check assertion within any monad. assertM :: Monad m => Bool -> m () assertM v = assert v $ return ()- -- Missing instances instance Hashable a => Hashable (Set.Set a) where
GenerateJSONParser.hs view
@@ -1,10 +1,16 @@-{-# 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 #-} module Main where import Control.Applicative+import Control.Monad import Data.Maybe+import Data.List (partition) import System.Exit import System.IO (stdin, stderr, stdout, IOMode(..)) import System.FilePath (splitExtension)@@ -35,6 +41,7 @@ defineFlag "autounify" True "Automatically unify suggested candidates" defineFlag "t:test" False "Try to run generated parser after" defineFlag "d:debug" False "Set this flag to see more debugging info"+defineFlag "y:typecheck" True "Set this flag to typecheck after unification" defineFlag "fakeFlag" True "Ignore this flag - it doesn't exist!!! It is workaround to library problem." -- Tracing is switched off:@@ -52,7 +59,7 @@ fatal msg = do report msg exitFailure -extractTypeFromJSONFile :: FilePath -> IO (Maybe Type)+extractTypeFromJSONFile :: FilePath -> IO (Maybe (FilePath, Type, Value)) extractTypeFromJSONFile inputFilename = withFileOrHandle inputFilename ReadMode stdin $ \hIn -> -- First we decode JSON input into Aeson's Value type@@ -64,20 +71,40 @@ return Nothing Just v -> do -- If decoding JSON was successful... -- We extract type structure from the JSON value.- let t = extractType v+ let t :: Type = extractType v myTrace $ "Type: " ++ pretty t- return $ Just t+ (v `typeCheck` t) `unless` fatal ("Typecheck against base type failed for "+ `Text.append` Text.pack inputFilename)+ return $ Just (inputFilename, t, v) +-- | Type checking all input files with given type,+-- and return a list of filenames for files that passed the check.+typeChecking :: Type -> [FilePath] -> [Value] -> IO [FilePath]+typeChecking ty filenames values = do+ when (not $ null failures ) $ report $ Text.unwords $ "Failed to typecheck with unified type: ":+ (Text.pack `map` failures)+ when ( null successes) $ fatal "No files passed the typecheck."+ return successes+ where+ checkedFiles = zip filenames $ map (`typeCheck` ty) values+ (map fst -> successes,+ map fst -> failures) = partition snd checkedFiles+ -- | Take a set of JSON input filenames, Haskell output filename, and generate module parsing these JSON files. generateHaskellFromJSONs :: [FilePath] -> FilePath -> IO () generateHaskellFromJSONs inputFilenames outputFilename = do -- Read type from each file- typeForEachFile <- catMaybes <$> mapM extractTypeFromJSONFile inputFilenames+ (filenames,+ typeForEachFile,+ valueForEachFile) <- (unzip3 . catMaybes) <$> mapM extractTypeFromJSONFile inputFilenames -- Unify all input types when (null typeForEachFile) $ do report "No valid JSON input file..." exitFailure let finalType = foldr1 unifyTypes typeForEachFile+ passedTypeCheck <- if flags_typecheck+ then typeChecking finalType filenames valueForEachFile+ else return filenames -- We split different dictionary labels to become different type trees (and thus different declarations.) let splitted = splitTypeByLabel "TopLevel" finalType myTrace $ "SPLITTED: " ++ pretty splitted@@ -96,7 +123,7 @@ -- We start by writing module header writeHaskellModule outputFilename unified when flags_test $- exitWith =<< system (unwords $ ["runghc", outputFilename] ++ inputFilenames)+ exitWith =<< system (unwords $ ["runghc", outputFilename] ++ passedTypeCheck) main :: IO () main = do filenames <- $initHFlags "json-autotype -- automatic type and parser generation from JSON"
+ GenerateTestJSON.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Main where++import Control.Applicative+import Data.Maybe+import System.Exit+import System.IO (stdin, stderr, stdout, IOMode(..))+import System.FilePath (splitExtension, (<.>))+import System.Directory (removeFile)+import System.Process (system)+import Control.Monad (forM_, forM, when)+import qualified Data.ByteString.Lazy.Char8 as BSL+import qualified Data.HashMap.Strict as Map+import Data.Aeson+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.Pretty+import Data.Aeson.AutoType.Type+import Data.Aeson.AutoType.Extract+import Data.Aeson.AutoType.Format+import Data.Aeson.AutoType.CodeGen+import Data.Aeson.AutoType.Util+import Data.Aeson.AutoType.Test+import HFlags++fst3 :: (t, t1, t2) -> t+fst3 (a, _, _) = a++-- * Command line flags+defineFlag "z:size" (10 :: Int) "Size of generated elements"+defineFlag "s:stem" ("Test" :: FilePath) "Test filename stem"+defineFlag "c:count" (100 :: Int) "Number of test cases to generate."+defineFlag "o:outputFilename" defaultOutputFilename "Write output to the given file"+defineFlag "suggest" True "Suggest candidates for unification"+defineFlag "autounify" True "Automatically unify suggested candidates"+defineFlag "t:test" False "Try to run generated parser after"+defineFlag "d:debug" False "Set this flag to see more debugging info"+defineFlag "keep" False "Keep also the successful tests"+defineFlag "fakeFlag" True "Ignore this flag - it doesn't exist!!! It is workaround to library problem."++-- Tracing is switched off:+myTrace :: String -> IO ()+myTrace msg = if flags_debug+ then putStrLn msg+ else return ()++-- | 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 :: FilePath -> IO (Maybe Type)+extractTypeFromJSONFile 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)+ myTrace ("Decoded JSON: " ++ pretty (decode bs :: Maybe Value))+ case decode bs of+ Nothing -> do report $ "Cannot decode JSON input from " `Text.append` Text.pack (show inputFilename)+ return Nothing+ Just 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++-- | 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+ putStrLn $ "Successfully generated " ++ show (length results) +++ " JSON files, out of planned " ++ show flags_count ++ " cases."+ where+ makeInputFilename = (<.>".json") . (flags_stem ++) . show+ makeOutputFilename = (<.>".hs") . (flags_stem ++) . show+ inputFilenames = map makeInputFilename [1..flags_count]+ outputFilenames = map makeOutputFilename [1..flags_count]++main :: IO ()+main = do filenames <- $initHFlags "testJSON -- automatic test JSON generation"+ -- TODO: should integrate all inputs into single type set!!!+ generateTestJSONs+
+ TestQC.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE TemplateHaskell #-}+module Main(+ main+ ) where++import Test.QuickCheck+--import Test.QuickCheck.Arbitrary++import Data.Aeson+import Data.Aeson.AutoType.Extract+import Data.Aeson.AutoType.Test() -- Arbitrary instance for Value++prop_typeCheck :: Value -> Bool+prop_typeCheck v = v `typeCheck` extractType v++{-+prop_typeSize :: Value -> Bool+prop_typeSize v = valueSize v >= typeSize (extractType v)++prop_valueAndValueTypeSize :: Value -> Bool+prop_valueAndValueTypeSize v = valueSize v >= valueTypeSize v++prop_valueTypeSizeAndTypeSize :: Value -> Bool+prop_valueTypeSizeAndTypeSize v = valueTypeSize v >= typeSize (extractType v) -}++main :: IO ()+main = quickCheck prop_typeCheck+ {- prop_typeSize,+ prop_valueAndValueTypeSize,+ prop_valueTypeSizeAndTypeSize]-}
changelog.md view
@@ -1,5 +1,11 @@ Changelog =========+ 0.2.5.12 Apr 2015++ * Added typechecking before and after type unification.+ * Added shrink for more informative QuickCheck testing.+ * Tested mostly using GHC 7.10.+ 0.2.5.11 Mar 2015 * Add short versions of command line flags: -o, -d, and -t.
json-autotype.cabal view
@@ -1,6 +1,6 @@ -- Build information for the package. name: json-autotype-version: 0.2.5.11+version: 0.2.5.12 synopsis: Automatic type declaration for JSON input data description: Generates datatype declarations with Aeson's "FromJSON" instances from a set of example ".json" files.@@ -27,7 +27,7 @@ author: Michal J. Gajda maintainer: mjgajda@gmail.com copyright: Copyright by Michal J. Gajda '2014-'2015-category: Web+category: Data, Tools build-type: Simple extra-source-files: README.md changelog.md cabal-version: >=1.10@@ -65,12 +65,12 @@ containers >=0.3 && <0.6, filepath >=1.3 && <1.5, hashable >=1.2 && <1.3,- hint >=0.4 && <0.5,- hflags >=0.4 && <0.5,- lens >=4.1 && <4.9,+ hint >=0.3 && <0.5,+ hflags >=0.3 && <0.5,+ lens >=4.1 && <4.10, mtl >=2.1 && <2.3, pretty >=1.1 && <1.3,- process >=1.2 && <1.4,+ process >=1.1 && <1.4, scientific >=0.3 && <0.5, text >=1.1 && <1.4, uniplate >=1.6 && <1.7,@@ -96,16 +96,87 @@ containers >=0.3 && <0.6, filepath >=1.3 && <1.5, hashable >=1.2 && <1.3,- hflags >=0.4 && <0.5,- lens >=4.1 && <4.9,+ hflags >=0.3 && <0.5,+ lens >=4.1 && <4.10, mtl >=2.1 && <2.3, pretty >=1.1 && <1.3,- process >=1.2 && <1.4,+ process >=1.1 && <1.4, scientific >=0.3 && <0.5, text >=1.1 && <1.4, uniplate >=1.6 && <1.7, unordered-containers >=0.2 && <0.3, vector >=0.9 && <0.11+ -- hs-source-dirs: + default-language: Haskell2010++-- test suites+executable json-autotype-random-test+ main-is: GenerateTestJSON.hs+ other-modules: Data.Aeson.AutoType.Util,+ Data.Aeson.AutoType.Test,+ Data.Aeson.AutoType.Type+ other-extensions: TemplateHaskell,+ ScopedTypeVariables,+ OverloadedStrings,+ FlexibleInstances,+ MultiParamTypeClasses,+ DeriveDataTypeable,+ DeriveGeneric,+ RecordWildCards+ build-depends: base >=4.3 && <4.9,+ GenericPretty >=1.2 && <1.3,+ aeson >=0.7 && <0.9,+ bytestring >=0.9 && <0.11,+ containers >=0.3 && <0.6,+ directory >=1.1 && <1.3,+ filepath >=1.3 && <1.5,+ hashable >=1.2 && <1.3,+ hflags >=0.3 && <0.5,+ lens >=4.1 && <4.10,+ mtl >=2.1 && <2.3,+ pretty >=1.1 && <1.3,+ process >=1.1 && <1.4,+ scientific >=0.3 && <0.5,+ text >=1.1 && <1.4,+ uniplate >=1.6 && <1.7,+ unordered-containers >=0.2 && <0.3,+ vector >=0.9 && <0.11,+ QuickCheck >=2.4 && <3.0+ -- hs-source-dirs: + default-language: Haskell2010++-- test suite with QuickCheck+executable json-autotype-qc-test+ main-is: TestQC.hs+ other-modules: Data.Aeson.AutoType.Util,+ Data.Aeson.AutoType.Test,+ Data.Aeson.AutoType.Type+ other-extensions: TemplateHaskell,+ ScopedTypeVariables,+ OverloadedStrings,+ FlexibleInstances,+ MultiParamTypeClasses,+ DeriveDataTypeable,+ DeriveGeneric,+ RecordWildCards+ build-depends: base >=4.3 && <4.9,+ GenericPretty >=1.2 && <1.3,+ aeson >=0.7 && <0.9,+ bytestring >=0.9 && <0.11,+ containers >=0.3 && <0.6,+ directory >=1.1 && <1.3,+ filepath >=1.3 && <1.5,+ hashable >=1.2 && <1.3,+ lens >=4.1 && <4.10,+ mtl >=2.1 && <2.3,+ pretty >=1.1 && <1.3,+ process >=1.1 && <1.4,+ scientific >=0.3 && <0.5,+ text >=1.1 && <1.4,+ uniplate >=1.6 && <1.7,+ unordered-containers >=0.2 && <0.3,+ vector >=0.9 && <0.11,+ QuickCheck >=2.4 && <3.0 -- hs-source-dirs: default-language: Haskell2010