json-autotype 0.2.1.4 → 0.2.2.0
raw patch · 8 files changed
+147/−98 lines, 8 filesdep +GenericPrettydep +prettydep +scientific
Dependencies added: GenericPretty, pretty, scientific
Files
- CLI.hs +0/−20
- Data/Aeson/AutoType/Extract.hs +18/−6
- Data/Aeson/AutoType/Format.hs +8/−9
- Data/Aeson/AutoType/Type.hs +16/−3
- Data/Aeson/AutoType/Util.hs +27/−2
- GenerateJSONParser.hs +68/−55
- changelog.md +4/−0
- json-autotype.cabal +6/−3
− CLI.hs
@@ -1,20 +0,0 @@--- | This module facilitates definition of command line interface.-module CLI (- defaultOutputFilename- , withFileOrHandle- ) where--import System.IO (withFile, IOMode(..), Handle)---- | Default output filname is used, when there is no explicit output file path, or it is "-" (stdout).-defaultOutputFilename :: FilePath-defaultOutputFilename = "JSONTypes.hs"---- | Generic function for opening file if the filename is not empty nor "-",--- or using given handle otherwise (probably stdout, stderr, or stdin).--- TODO: Should it become utility function?-withFileOrHandle :: FilePath -> IOMode -> Handle -> (Handle -> IO r) -> IO r-withFileOrHandle "" _ handle action = action handle-withFileOrHandle "-" _ handle action = action handle-withFileOrHandle name ioMode _ action = withFile name ioMode action -
Data/Aeson/AutoType/Extract.hs view
@@ -1,3 +1,4 @@+-- | Extraction and unification of AutoType's @Type@ from Aeson @Value@. module Data.Aeson.AutoType.Extract(valueSize, typeSize, valueTypeSize, valueDepth, Dict(..), Type(..), emptyType,@@ -45,11 +46,7 @@ extractType (Number _) = TNum extractType (String _) = TString extractType (Array a) | V.null a = TArray emptyType-extractType (Array a) = V.foldl1' unifyTypes $ V.map extractType a--simplifyUnion :: Type -> Type-simplifyUnion (TUnion s) | Set.size s == 1 = head $ Set.toList s-simplifyUnion t = t+extractType (Array a) = TArray $ V.foldl1' unifyTypes $ V.map extractType a unifyTypes :: Type -> Type -> Type unifyTypes TBool TBool = TBool@@ -66,16 +63,21 @@ 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 where+ -- We partition our types for easier unification into simple and compound (uSimple, uCompound) = Set.partition isSimple u (vSimple, vCompound) = Set.partition isSimple v assertions = assert (Set.null $ Set.filter (not . isArray) uArr) .- assert (Set.null $ Set.filter (not . isArray) vArr) + assert (Set.null $ Set.filter (not . isArray) vArr)+ -- 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@@ -87,6 +89,16 @@ else [foldl1' unifyTypes arrays]-} --arrays = Set.toList $ uArr `Set.union` vArr +-- | Smart constructor for union types. union :: Set Type -> Type union = simplifyUnion . TUnion +-- | Simplify TUnion's so there is no TUnion directly inside TUnion.+-- If there is only one element of the set, then return this single+-- element as a type.+simplifyUnion :: Type -> Type+simplifyUnion (TUnion s) | Set.size s == 1 = head $ Set.toList s+simplifyUnion (TUnion s) = TUnion $ Set.unions $ map elements $ Set.toList s+ where+ elements (TUnion elems) = elems+ elements s = Set.singleton s
Data/Aeson/AutoType/Format.hs view
@@ -74,10 +74,10 @@ fieldDecl (name, fType) = Text.concat [" ", normalizeFieldName identifier name, " :: ", fType] normalizeFieldName :: Text -> Text -> Text-normalizeFieldName identifier = escapeKeywords .- uncapitalize .- (normalizeTypeName identifier `Text.append`) .- normalizeTypeName+normalizeFieldName _identifier = escapeKeywords .+ uncapitalize .+ --(normalizeTypeName identifier `Text.append`) .+ normalizeTypeName keywords :: Set Text keywords = Set.fromList ["type", "data", "module"]@@ -139,15 +139,14 @@ return $! TUnion $! Set.fromList m splitTypeByLabel' l (TArray a) = do m <- splitTypeByLabel' (l `Text.append` "Elt") a return $! TArray m-splitTypeByLabel' l (TObj o) = do kvs <- forM d $ \(k, v) -> do+splitTypeByLabel' l (TObj o) = do kvs <- forM (Map.toList $ unDict o) $ \(k, v) -> do component <- splitTypeByLabel' k v return (k, component) addType l (TObj $ Dict $ Map.fromList kvs) return $! TLabel l- where- d = Map.toList $ unDict o --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@@ -229,13 +228,13 @@ map (splitted Map.!) cset replace :: [Text] -> Map Text Type -> Map Text Type replace cset@(c:_) s = Map.insert c (unifiedType cset) (foldr Map.delete s cset)- replace [] _ = error "Empty cset in replace"+ replace [] _ = error "Empty candidate set in replace" replacements :: Map Text Type -> Map Text Type replacements s = foldr replace s candidates labelMapping :: Map Text Text labelMapping = Map.fromList $ concatMap mapEntry candidates mapEntry cset@(c:_) = [(x, c) | x <- cset]- mapEntry [] = error "Empty cset in mapEntry"+ mapEntry [] = error "Empty candidate set in mapEntry" -- | Remaps type labels according to a `Map`. remapLabels :: Map Text Text -> Type -> Type
Data/Aeson/AutoType/Type.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE ViewPatterns, OverloadedStrings #-} module Data.Aeson.AutoType.Type(typeSize, Dict(..), keys, get, withDict, Type(..), emptyType,@@ -16,14 +18,23 @@ import Data.List (sort) import Data.Ord (comparing) import Data.Generics.Uniplate+import Text.PrettyPrint+import Text.PrettyPrint.GenericPretty+import qualified Data.Text as Text +import Data.Aeson.AutoType.Pretty+ -- | Type alias for HashMap type Map = HashMap -- * Dictionary of types indexed by names. newtype Dict = Dict { unDict :: Map Text Type }- deriving (Eq, Data, Typeable)+ deriving (Eq, Data, Typeable, Generic) +instance Out Dict where+ doc = doc . unDict+ docPrec p = docPrec p . unDict+ instance Show Dict where show = show . sort . Hash.toList . unDict @@ -44,7 +55,9 @@ TLabel Text | TObj Dict | TArray Type- deriving (Show,Eq, Ord, Data, Typeable)+ deriving (Show,Eq, Ord, Data, Typeable, Generic)++instance Out Type -- These are missing Uniplate instances... {-
Data/Aeson/AutoType/Util.hs view
@@ -1,7 +1,32 @@-module Data.Aeson.AutoType.Util where+module Data.Aeson.AutoType.Util( withFileOrHandle+ , withFileOrDefaultHandle+ , assertM ) where -import Data.Hashable+import Data.Hashable import qualified Data.Set as Set+import Control.Exception(assert)+import System.IO (withFile, IOMode(..), Handle, stdin, stdout)++-- | Generic function for opening file if the filename is not empty nor "-",+-- or using given handle otherwise (probably stdout, stderr, or stdin).+-- TODO: Should it become utility function?+withFileOrHandle :: FilePath -> IOMode -> Handle -> (Handle -> IO r) -> IO r+withFileOrHandle "" _ handle action = action handle+withFileOrHandle "-" _ handle action = action handle+withFileOrHandle name ioMode _ action = withFile name ioMode action ++withFileOrDefaultHandle :: FilePath -> IOMode -> (Handle -> IO r) -> IO r+withFileOrDefaultHandle "-" ReadMode action = action stdin+withFileOrDefaultHandle "-" WriteMode action = action stdout+withFileOrDefaultHandle "-" otherMode _ = error $ "Incompatible io mode ("+ ++ show otherMode+ ++ ") for `-` in withFileOrDefaultHandle." +withFileOrDefaultHandle filename ioMode action = withFile filename ioMode action+++assertM :: Monad m => Bool -> m ()+assertM v = assert v $ return ()+ -- Missing instances instance Hashable a => Hashable (Set.Set a) where
GenerateJSONParser.hs view
@@ -1,85 +1,98 @@ {-# LANGUAGE TemplateHaskell, ScopedTypeVariables, OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric, StandaloneDeriving, ViewPatterns #-} {-# 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 Control.Monad (forM_, when)-import Control.Exception(assert) import qualified Data.ByteString.Lazy.Char8 as BSL import qualified Data.HashMap.Strict as Map import Data.Aeson import qualified Data.Text as Text import qualified Data.Text.IO as Text import Data.Text (Text)+import Text.PrettyPrint.GenericPretty (pretty) +import Data.Aeson.AutoType.Pretty import Data.Aeson.AutoType.Type import Data.Aeson.AutoType.Extract import Data.Aeson.AutoType.Format-import CLI+import Data.Aeson.AutoType.CodeGen+import Data.Aeson.AutoType.Util import HFlags fst3 :: (t, t1, t2) -> t fst3 (a, _, _) = a -assertM :: Monad m => Bool -> m ()-assertM v = assert v $ return ()--capitalize :: Text -> Text-capitalize input = Text.toUpper (Text.take 1 input)- `Text.append` Text.drop 1 input--header :: Text -> Text-header moduleName = Text.unlines [- "{-# LANGUAGE TemplateHaskell #-}"- ,Text.concat ["module ", capitalize moduleName, " where"]- ,""- ,"import Data.Text (Text)"- ,"import Data.Aeson(decode, Value(..), FromJSON(..),"- ," (.:), (.:?), (.!=))"- ,"import Data.Aeson.TH"- ,""]- -- * Command line flags-defineFlag "filename" (defaultOutputFilename :: FilePath) "Write output to the given file"-defineFlag "suggest" True "Suggest candidates for unification"-defineFlag "autounify" True "Automatically unify suggested candidates"-defineFlag "fakeFlag" True "Ignore this flag - it doesn't exist!!!"+defineFlag "outputFilename" defaultOutputFilename "Write output to the given file"+defineFlag "suggest" True "Suggest candidates for unification"+defineFlag "autounify" True "Automatically unify suggested candidates"+defineFlag "debug" False "Set this flag to see more debugging info"+defineFlag "fakeFlag" True "Ignore this flag - it doesn't exist!!!" -- Tracing is switched off: myTrace :: String -> IO ()-myTrace _msg = return ()---myTrace = putStrLn +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++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.+generateHaskellFromJSONs :: [FilePath] -> FilePath -> IO ()+generateHaskellFromJSONs inputFilenames outputFilename =+ forM_ inputFilenames $ \inputFilename -> do+ -- Read type from each file+ typeForEachFile <- catMaybes <$> mapM extractTypeFromJSONFile inputFilenames+ -- Unify all input types+ 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+ main :: IO () main = do filenames <- $initHFlags "json-autotype -- automatic type and parser generation from JSON"- let (moduleName, extension) = splitExtension $- if flags_filename == "-"- then defaultOutputFilename- else flags_filename- assertM (extension == ".hs") -- TODO: should integrate all inputs into single type set!!!- withFileOrHandle flags_filename WriteMode stdout $ \hOut ->- forM_ filenames $ \filename ->- withFileOrHandle filename ReadMode stdin $ \hIn ->- do bs <- BSL.hGetContents hIn- Text.hPutStrLn stderr $ "Processing " `Text.append` Text.pack (show moduleName)- myTrace ("Decoded JSON: " ++ show (decode bs :: Maybe Value))- let Just v = decode bs- let t = extractType v- myTrace $ "type: " ++ show t- let splitted = splitTypeByLabel "TopLevel" t- myTrace $ "splitted: " ++ show splitted- Text.hPutStrLn hOut $ header $ Text.pack moduleName- assertM $ not $ any hasNonTopTObj $ Map.elems splitted- let uCands = unificationCandidates splitted- myTrace $ "candidates: " ++ show uCands- when flags_suggest $ forM_ uCands $ \cs -> do- putStr "-- "- Text.putStrLn $ "=" `Text.intercalate` cs- let unified = if flags_autounify- then unifyCandidates uCands splitted- else splitted- myTrace $ "unified: " ++ show unified- Text.hPutStrLn hOut $ displaySplitTypes unified-+ generateHaskellFromJSONs filenames flags_outputFilename
changelog.md view
@@ -1,5 +1,9 @@ Changelog =========+ 0.2.2.0 Oct 2014++ * GenerateJSONParser may now take multiple input samples to produce single parser.+ * Fixed automated testing for all example files. 0.2.1.4 Oct 2014
json-autotype.cabal view
@@ -1,6 +1,6 @@ -- Build information for the package. name: json-autotype-version: 0.2.1.4+version: 0.2.2.0 synopsis: Automatic type declaration for JSON input data description: Generates datatype declarations with Aeson's "FromJSON" instances from a set of example ".json" files.@@ -41,10 +41,10 @@ executable json-autotype main-is: GenerateJSONParser.hs other-modules: Data.Aeson.AutoType.Type- Data.Aeson.AutoType.Util Data.Aeson.AutoType.Extract Data.Aeson.AutoType.Format- CLI+ -- internal module+ Data.Aeson.AutoType.Util other-extensions: TemplateHaskell, ScopedTypeVariables, OverloadedStrings,@@ -58,6 +58,9 @@ containers >=0.3 && <0.6, vector >=0.9 && <0.11, aeson >=0.7 && <0.9,+ pretty >=1.1 && <1.3,+ GenericPretty >=1.2 && <1.3,+ scientific >=0.3 && <0.5, text >=1.1 && <1.3, hashable >=1.2 && <1.3, uniplate >=1.6 && <1.7,