diff --git a/CLI.hs b/CLI.hs deleted file mode 100644 --- a/CLI.hs +++ /dev/null @@ -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 - diff --git a/Data/Aeson/AutoType/Extract.hs b/Data/Aeson/AutoType/Extract.hs --- a/Data/Aeson/AutoType/Extract.hs +++ b/Data/Aeson/AutoType/Extract.hs @@ -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 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 @@ -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 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 @@ -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... {- diff --git a/Data/Aeson/AutoType/Util.hs b/Data/Aeson/AutoType/Util.hs --- a/Data/Aeson/AutoType/Util.hs +++ b/Data/Aeson/AutoType/Util.hs @@ -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 diff --git a/GenerateJSONParser.hs b/GenerateJSONParser.hs --- a/GenerateJSONParser.hs +++ b/GenerateJSONParser.hs @@ -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 diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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 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.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,