json-autotype 0.2.2.0 → 0.2.3.0
raw patch · 6 files changed
+252/−50 lines, 6 filesdep +process
Dependencies added: process
Files
- Data/Aeson/AutoType/CodeGen.hs +81/−0
- Data/Aeson/AutoType/Format.hs +74/−15
- Data/Aeson/AutoType/Pretty.hs +51/−0
- GenerateJSONParser.hs +26/−23
- changelog.md +6/−1
- json-autotype.cabal +14/−11
+ Data/Aeson/AutoType/CodeGen.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE OverloadedStrings #-}+module Data.Aeson.AutoType.CodeGen(+ writeHaskellModule+ , defaultOutputFilename+ ) where++import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import Data.Text+import qualified Data.HashMap.Strict as Map+import System.FilePath+import System.IO++import Data.Aeson.AutoType.Type+import Data.Aeson.AutoType.Format+import Data.Aeson.AutoType.Util++-- | Default output filname is used, when there is no explicit output file path, or it is "-" (stdout).+-- Default module name is consistent with it.+defaultOutputFilename :: FilePath+defaultOutputFilename = "JSONTypes.hs"++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, ScopedTypeVariables #-}"+ ,"{-# LANGUAGE RecordWildCards, OverloadedStrings #-}"+ ,""+ ,Text.concat ["module ", capitalize moduleName, " where"]+ ,""+ ,"import System.Exit (exitFailure, exitSuccess)"+ ,"import System.IO (stderr, hPutStrLn)"+ ,"import qualified Data.ByteString.Lazy.Char8 as BSL"+ ,"import System.Environment (getArgs)"+ ,"import Control.Monad (forM_, mzero)"+ ,"import Control.Applicative"+ ,"import Data.Aeson(decode, Value(..), FromJSON(..), ToJSON(..),"+ ," (.:), (.:?), (.!=), (.=), object)"+ ,"import Data.Text (Text)"+ ,"import Data.Aeson.TH" + ,""]++epilogue :: Text+epilogue = Text.unlines+ [""+ ,"parse :: FilePath -> IO TopLevel"+ ,"parse filename = do input <- BSL.readFile filename"+ ," 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"+ ," 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"+ ,""]++-- Write a Haskell module to an output file, or stdout if `-` filename is given.+writeHaskellModule :: FilePath -> Map.HashMap Text Type -> IO ()+writeHaskellModule outputFilename types =+ withFileOrHandle outputFilename WriteMode stdout $ \hOut -> do+ assertM (extension == ".hs")+ Text.hPutStrLn hOut $ header $ Text.pack moduleName+ -- We write types as Haskell type declarations to output handle+ Text.hPutStrLn hOut $ displaySplitTypes types+ Text.hPutStrLn hOut epilogue+ where+ (moduleName, extension) = splitExtension $+ if outputFilename == "-"+ then defaultOutputFilename+ else outputFilename+
Data/Aeson/AutoType/Format.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns, OverloadedStrings #-} module Data.Aeson.AutoType.Format( displaySplitTypes, splitTypeByLabel, unificationCandidates, unifyCandidates@@ -19,7 +20,7 @@ import Data.Text (Text) import Data.Set (Set ) import Data.List (foldl1')-import Data.Char (isAlpha)+import Data.Char (isAlpha, isDigit) import Control.Monad.State.Class import Control.Monad.State.Strict(State, runState) import qualified Data.Graph as Graph@@ -49,38 +50,90 @@ tShow = Text.pack . show wrapDecl :: Text -> Text -> Text-wrapDecl identifier contents = Text.unlines [header, contents, " } deriving (Show,Eq)"- ,"\nderiveJSON defaultOptions ''" `Text.append` identifier]+wrapDecl identifier contents = Text.unlines [header, contents, " } deriving (Show,Eq)"]+ --,"\nderiveJSON defaultOptions ''" `Text.append` identifier] where header = Text.concat ["data ", identifier, " = ", identifier, " { "] +-- | Explanatory type alias for making declarations+-- First element of the pair is original JSON identifier,+-- second element of the pair is the mapped identifier name in Haskell.+type MappedKey = (Text, Text)++-- | 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*.+makeFromJSON :: Text -> [MappedKey] -> Text+makeFromJSON identifier contents =+ Text.unlines [+ Text.unwords ["instance FromJSON", identifier, "where"]+ , Text.unwords [" parseJSON (Object v) =", identifier, inner]+ , " parseJSON _ = mzero" ]+ where+ inner = if Text.null inner'+ then ""+ else "<$>" `Text.append` inner'+ inner' = Text.intercalate " <*> " $+ map (takeValue . fst) contents+ takeValue jsonId = Text.concat ["v .: \"", jsonId, "\""]+-- Contents example for wrapFromJSON:+-- " <$>+--" v .: "hexValue" <*>+--" v .: "colorName\""++-- | 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 declaration+makeToJSON :: Text -> [MappedKey] -> Text+makeToJSON identifier contents =+ Text.unlines [+ Text.concat ["instance ToJSON ", identifier, " where"],+ Text.concat [" toJSON (", identifier, " {..}) = object [", inner, "]"]+ ]+ where+ inner = ", " `Text.intercalate`+ map putValue contents+ putValue (jsonId, haskellId) = Text.unwords [escapeText jsonId, ".=", haskellId]+ escapeText = Text.pack . show . Text.unpack+-- Contents example for wrapToJSON+--"hexValue" .= hexValue+-- ,"colorName" .= colorName]++ -- | Makes a generic identifier name. genericIdentifier :: DeclM Text genericIdentifier = do i <- stepM return $! "Obj" `Text.append` tShow i --- * Naive type printing.+-- * Printing a single type declaration newDecl :: Text -> [(Text, Type)] -> DeclM Text newDecl identifier kvs = do attrs <- forM kvs $ \(k, v) -> do formatted <- formatType v- return (k, formatted)- let decl = wrapDecl identifier $ fieldDecls attrs+ return (k, normalizeFieldName identifier k, formatted)+ let fieldMapping = map (\(jn, hn, _) -> (jn, hn)) attrs+ let decl = Text.unlines [wrapDecl identifier $ fieldDecls attrs+ ,""+ ,makeFromJSON identifier fieldMapping+ ,""+ ,makeToJSON identifier fieldMapping] decls %%= (\ds -> ((), decl:ds)) return identifier where fieldDecls attrList = Text.intercalate ",\n" $ map fieldDecl attrList- fieldDecl :: (Text, Text) -> Text- fieldDecl (name, fType) = Text.concat [" ", normalizeFieldName identifier name, " :: ", fType]+ fieldDecl :: (Text, Text, Text) -> Text+ fieldDecl (_jsonName, haskellName, fType) = Text.concat [+ " ", haskellName, " :: ", fType] +-- | 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.) 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"]+keywords = Set.fromList ["type", "data", "module", "class", "where", "let", "do"] escapeKeywords :: Text -> Text escapeKeywords k | k `Set.member` keywords = k `Text.append` "_"@@ -171,10 +224,16 @@ normalizeTypeName :: Text -> Text normalizeTypeName = escapeKeywords .+ escapeFirstNonAlpha . Text.concat . map capitalize . filter (not . Text.null) .- Text.split (not . isAlpha)+ Text.split (not . acceptableInVariable)+ where+ acceptableInVariable c = isAlpha c || isDigit c+ escapeFirstNonAlpha cs | Text.null cs = cs+ escapeFirstNonAlpha cs@(Text.head -> c) | isAlpha c = cs+ escapeFirstNonAlpha cs = "_" `Text.append` cs capitalize :: Text -> Text capitalize word = Text.toUpper first `Text.append` rest
+ Data/Aeson/AutoType/Pretty.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE TemplateHaskell, ScopedTypeVariables, OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric, StandaloneDeriving, ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Instances of @Text.PrettyPrint.Out@ class to visualize+-- Aeson @Value@ data structure. +module Data.Aeson.AutoType.Pretty() where++import qualified Data.HashMap.Strict as Hash+import Data.HashMap.Strict(HashMap)+import Data.Aeson+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import Data.Text (Text)+import Data.Set as Set(Set, fromList, toList)+import Data.Scientific+import Data.Vector as V(Vector(..), toList)+import Text.PrettyPrint.GenericPretty+import Text.PrettyPrint++formatPair :: (Out a, Out b) => (a, b) -> Doc+formatPair (a, b) = nest 1 (doc a <+> ": " <+> doc b <+> ",")++-- * This is to make prettyprinting possible for Aeson @Value@ type.+instance Out Scientific where+ doc = doc . show+ docPrec _ = doc++instance (Out a) => Out (Vector a) where+ doc (V.toList -> v) = "<" <+> doc v <+> ">"+ docPrec _ = doc++deriving instance Generic Value++instance Out Value++instance (Out a) => Out (Set a) where+ doc (Set.toList -> s) = "{" <+> doc s <+> "}"+ docPrec _ = doc++instance (Out a, Out b) => Out (HashMap a b) where+ doc (Hash.toList -> dict) = (foldl ($$) "{" $+ map formatPair dict)+ $$ nest 1 "}"+ + docPrec _ = doc++instance Out Text where+ doc = text . Text.unpack -- TODO: check if there may be direct way?+ docPrec _ = doc+
GenerateJSONParser.hs view
@@ -8,6 +8,7 @@ import System.Exit import System.IO (stdin, stderr, stdout, IOMode(..)) import System.FilePath (splitExtension)+import System.Process (system) import Control.Monad (forM_, when) import qualified Data.ByteString.Lazy.Char8 as BSL import qualified Data.HashMap.Strict as Map@@ -32,6 +33,7 @@ defineFlag "outputFilename" defaultOutputFilename "Write output to the given file" defineFlag "suggest" True "Suggest candidates for unification" defineFlag "autounify" True "Automatically unify suggested candidates"+defineFlag "test" False "Try to run generated parser after" defineFlag "debug" False "Set this flag to see more debugging info" defineFlag "fakeFlag" True "Ignore this flag - it doesn't exist!!!" @@ -68,29 +70,30 @@ -- | 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+generateHaskellFromJSONs inputFilenames outputFilename = 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+ when flags_test $+ exitWith =<< system (unwords $ ["runghc", outputFilename] ++ inputFilenames) main :: IO () main = do filenames <- $initHFlags "json-autotype -- automatic type and parser generation from JSON"
changelog.md view
@@ -1,6 +1,11 @@ Changelog =========- 0.2.2.0 Oct 2014+ 0.2.3.0 Nov 2014++ * Explicit JSON parser generation to avoid conflicts between Haskell keywords and field names.+ * Renaming of Haskell field names with a prefix of object name (data type.)++ 0.2.2.0 Nov 2014 * GenerateJSONParser may now take multiple input samples to produce single parser. * Fixed automated testing for all example files.
json-autotype.cabal view
@@ -1,6 +1,6 @@ -- Build information for the package. name: json-autotype-version: 0.2.2.0+version: 0.2.3.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.@@ -43,6 +43,8 @@ other-modules: Data.Aeson.AutoType.Type Data.Aeson.AutoType.Extract Data.Aeson.AutoType.Format+ Data.Aeson.AutoType.Pretty+ Data.Aeson.AutoType.CodeGen -- internal module Data.Aeson.AutoType.Util other-extensions: TemplateHaskell,@@ -52,22 +54,23 @@ MultiParamTypeClasses, DeriveDataTypeable build-depends: base >=4.3 && <4.8,- lens >=4.1 && <4.5,+ GenericPretty >=1.2 && <1.3,+ MissingH >=1.2 && <1.3,+ aeson >=0.7 && <0.9, bytestring >=0.9 && <0.11,- unordered-containers >=0.2 && <0.3, containers >=0.3 && <0.6,- vector >=0.9 && <0.11,- aeson >=0.7 && <0.9,+ filepath >=1.3 && <1.4,+ hashable >=1.2 && <1.3,+ hflags >=0.4 && <0.5,+ lens >=4.1 && <4.5,+ mtl >=2.1 && <2.2, pretty >=1.1 && <1.3,- GenericPretty >=1.2 && <1.3,+ process >=1.2 && <1.4, scientific >=0.3 && <0.5, text >=1.1 && <1.3,- hashable >=1.2 && <1.3, uniplate >=1.6 && <1.7,- MissingH >=1.2 && <1.3,- hflags >=0.4 && <0.5,- filepath >=1.3 && <1.4,- mtl >=2.1 && <2.2+ unordered-containers >=0.2 && <0.3,+ vector >=0.9 && <0.11 -- hs-source-dirs: default-language: Haskell2010