diff --git a/Data/Aeson/AutoType/CodeGen.hs b/Data/Aeson/AutoType/CodeGen.hs new file mode 100644 --- /dev/null +++ b/Data/Aeson/AutoType/CodeGen.hs @@ -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 + 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 @@ -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 diff --git a/Data/Aeson/AutoType/Pretty.hs b/Data/Aeson/AutoType/Pretty.hs new file mode 100644 --- /dev/null +++ b/Data/Aeson/AutoType/Pretty.hs @@ -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 + diff --git a/GenerateJSONParser.hs b/GenerateJSONParser.hs --- a/GenerateJSONParser.hs +++ b/GenerateJSONParser.hs @@ -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" diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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. 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.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