diff --git a/Data/Aeson/AutoType/CodeGen.hs b/Data/Aeson/AutoType/CodeGen.hs --- a/Data/Aeson/AutoType/CodeGen.hs +++ b/Data/Aeson/AutoType/CodeGen.hs @@ -17,19 +17,23 @@ -- | Available output languages. data Lang = Haskell + | HaskellStrict | Elm -- | 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 :: Lang -> FilePath -defaultOutputFilename Haskell = defaultHaskellFilename -defaultOutputFilename Elm = defaultElmFilename +defaultOutputFilename Haskell = defaultHaskellFilename +defaultOutputFilename HaskellStrict = defaultHaskellFilename +defaultOutputFilename Elm = defaultElmFilename -- | Write a Haskell module to an output file, or stdout if `-` filename is given. writeModule :: Lang -> FilePath -> Text -> Map.HashMap Text Type -> IO () -writeModule Haskell = writeHaskellModule -writeModule Elm = writeElmModule +writeModule Haskell = writeHaskellModule +writeModule HaskellStrict = writeHaskellModule +writeModule Elm = writeElmModule -- | Run module in a given language. -runModule Haskell = runHaskellModule -runModule Elm = runElmModule +runModule Haskell = runHaskellModule +runModule HaskellStrict = runHaskellModuleStrict +runModule Elm = runElmModule diff --git a/Data/Aeson/AutoType/CodeGen/Elm.hs b/Data/Aeson/AutoType/CodeGen/Elm.hs --- a/Data/Aeson/AutoType/CodeGen/Elm.hs +++ b/Data/Aeson/AutoType/CodeGen/Elm.hs @@ -16,6 +16,8 @@ import Data.Monoid ((<>)) import System.FilePath import System.IO +import System.Process (system) +import System.Exit (ExitCode) import Data.Aeson.AutoType.Format import Data.Aeson.AutoType.Type @@ -32,7 +34,7 @@ ,"" ,"-- elm-package install toastal/either" ,"-- elm-package install NoRedInk/elm-decode-pipeline" - ,"import Either exposing (Either, mapBoth)" + ,"import Either exposing (Either, unpack)" ,"import Json.Encode exposing (..)" ,"import Json.Decode exposing (..)" ,"import Json.Decode.Pipeline exposing (..)" @@ -59,4 +61,7 @@ else outputFilename normalizeTypeName' = Text.unpack . normalizeTypeName . Text.pack -runElmModule = error "Yet undefined!" +runElmModule :: [String] -> IO ExitCode +runElmModule arguments = do + hPutStrLn stderr "Compiling *not* running Elm module for a test." + system $ Prelude.unwords $ ["elm", "make", Prelude.head arguments] -- ignore parsing args diff --git a/Data/Aeson/AutoType/CodeGen/ElmFormat.hs b/Data/Aeson/AutoType/CodeGen/ElmFormat.hs --- a/Data/Aeson/AutoType/CodeGen/ElmFormat.hs +++ b/Data/Aeson/AutoType/CodeGen/ElmFormat.hs @@ -21,12 +21,11 @@ import qualified Data.Set as Set import qualified Data.Text as Text import Data.Text (Text) -import Data.Set (Set ) +import Data.Set (Set, toList) import Data.List (foldl1') import Data.Char (isAlpha, isDigit) import Control.Monad.State.Class import Control.Monad.State.Strict(State, runState) -import qualified Data.Graph as Graph import GHC.Generics (Generic) import Data.Aeson.AutoType.Type @@ -99,9 +98,22 @@ getDecoder TBool = "Json.Decode.bool" getDecoder (TArray t) = "Json.Decode.list (" <> getDecoder t <> ")" getDecoder (TLabel l) = decoderIdent l -getDecoder (TObj o) = error "getDecoder cannot handle complex object types!" -getDecoder (TUnion u) = error $ "getDecoder cannot yet handle union types:" <> show u +getDecoder (TObj o) = error "getDecoder cannot handle complex object types!" +getDecoder (TUnion u) = case nonNull of + [] -> "Json.Decode.value" + [x] -> getDecoder x + _ -> foldl1' altDecoder $ map getDecoder nonNull + where + nonNull = nonNullComponents u +--error $ "getDecoder cannot yet handle union types:" <> show u +altDecoder a b = "(Json.Decode.oneOf [Json.Decode.map Either.Left (" + <> a <> "), Json.Decode.map Either.Right (" + <> b <> ")])" +{-Json.Decode.Pipeline.decode Something +"Json.Decode.Pipeline " <>-} + + decoderIdent ident = "decode" <> capitalize (normalizeTypeName ident) -- Contents example for wrapFromJSON: -- " <$> @@ -123,7 +135,7 @@ ] where makeEncoder (jsonId, haskellId, _typeText, ty, _nullable) = Text.concat [ - "(", tShow jsonId, ", ", getEncoder ty, " <| record.", normalizeFieldName identifier jsonId, ")" + "(", tShow jsonId, ", (", getEncoder ty, ") record.", normalizeFieldName identifier jsonId, ")" ] --"answers", Json.Encode.list <| List.map encodeAnswer <| record.answers escapeText = Text.pack . show . Text.unpack @@ -132,13 +144,19 @@ getEncoder TString = "Json.Encode.string" getEncoder TNum = "Json.Encode.float" getEncoder TBool = "Json.Encode.bool" -getEncoder TNull = "Json.Encode.complexType" +getEncoder TNull = "identity" getEncoder (TLabel l) = encoderIdent l -getEncoder (TArray e) = "Json.Encode.list <| List.map (" <> getEncoder e <> ")" +getEncoder (TArray e) = "Json.Encode.list << List.map (" <> getEncoder e <> ")" getEncoder (TObj o) = error $ "Seeing direct object encoder: " <> show o -getEncoder (TUnion u) = "oneOf [" <> joinWith ", " (makeUnionDecoder u) <> "]" +getEncoder (TUnion u) = case nonNull of + [] -> "identity" + [x] -> getDecoder x + _ -> foldl1' altEncoder $ map getEncoder nonNull + where + nonNull = nonNullComponents u -makeUnionDecoder u = error $ "Unfinished union decoding:" <> show u +altEncoder a b = "Either.unpack (" <> a <> ") (" <> b <> ")" + -- Contents example for wrapToJSON --"hexValue" .= hexValue -- ,"colorName" .= colorName] @@ -207,17 +225,13 @@ formatType (TUnion u) = wrap <$> case length nonNull of 0 -> return emptyTypeRepr 1 -> formatType $ head nonNull - _ -> alts <$> mapM formatType nonNull + _ -> foldl1' join <$> mapM formatType nonNull where nonNull = nonNullComponents u wrap :: Text -> Text wrap inner | TNull `Set.member` u = Text.concat ["(Maybe (", inner, "))"] | otherwise = inner - alts :: [Text] -> Text - alts [alt] = alt - alts (alt:others) = join alt $ alts others - where - join fAlt fOthers = Text.concat ["Either (", fAlt, ") (", fOthers, ")"] + join fAlt fOthers = Text.concat ["Either (", fAlt, ") (", fOthers, ")"] formatType (TArray a) = do inner <- formatType a return $ Text.concat ["List (", inner, ")"] formatType (TObj o) = do ident <- genericIdentifier @@ -228,7 +242,7 @@ formatType t = return $ "ERROR: Don't know how to handle: " `Text.append` tShow t emptyTypeRepr :: Text -emptyTypeRepr = "(Maybe ComplexType)" -- default, accepts future extension where we found no data +emptyTypeRepr = "Json.Decode.Value" -- default, accepts future extension where we found no data runDecl :: DeclM a -> Text runDecl decl = Text.unlines $ finalState ^. decls @@ -244,32 +258,6 @@ addType :: Text -> Type -> TypeTreeM () addType label typ = modify $ Map.insertWith (++) label [typ] -{- -splitTypeByLabel' :: Text -> Type -> TypeTreeM Type -splitTypeByLabel' _ TString = return TString -splitTypeByLabel' _ TNum = return TNum -splitTypeByLabel' _ TBool = return TBool -splitTypeByLabel' _ TNull = return TNull -splitTypeByLabel' _ (TLabel r) = assert False $ return $ TLabel r -- unnecessary? -splitTypeByLabel' l (TUnion u) = do m <- mapM (splitTypeByLabel' l) $ Set.toList u - 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 (Map.toList $ unDict o) $ \(k, v) -> do - component <- splitTypeByLabel' k v - return (k, component) - addType l (TObj $ Dict $ Map.fromList kvs) - return $! TLabel l - --- | 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 - finalize (TLabel l) = assert (l == topLabel) $ return () - finalize topLevel = addType topLabel topLevel - initialState = Map.empty - (_, finalState) = runState (splitTypeByLabel' topLabel t >>= finalize) initialState - -} formatObjectType :: Text -> Type -> DeclM Text formatObjectType identifier (TObj o) = newDecl identifier d where @@ -305,13 +293,6 @@ escapeFirstNonAlpha cs | Text.null cs = cs escapeFirstNonAlpha cs@(Text.head -> c) | isAlpha c = cs escapeFirstNonAlpha cs = "_" `Text.append` cs - --- | Topological sorting of splitted types so that it is accepted declaration order. -toposort :: Map Text Type -> [(Text, Type)] -toposort splitted = map ((id &&& (splitted Map.!)) . fst3 . graphKey) $ Graph.topSort graph - where - (graph, graphKey) = Graph.graphFromEdges' $ map makeEntry $ Map.toList splitted - makeEntry (k, v) = (k, k, allLabels v) -- | Computes all type labels referenced by a given type. allLabels :: Type -> [Text] diff --git a/Data/Aeson/AutoType/CodeGen/Haskell.hs b/Data/Aeson/AutoType/CodeGen/Haskell.hs --- a/Data/Aeson/AutoType/CodeGen/Haskell.hs +++ b/Data/Aeson/AutoType/CodeGen/Haskell.hs @@ -4,6 +4,7 @@ module Data.Aeson.AutoType.CodeGen.Haskell( writeHaskellModule , runHaskellModule + , runHaskellModuleStrict , defaultHaskellFilename ) where @@ -69,7 +70,7 @@ ," case decode input of" ," Nothing -> fatal $ case (decode input :: Maybe Value) of" ," Nothing -> \"Invalid JSON file: \" ++ filename" - ," Just v -> \"Mismatched JSON value from file: \" ++ filename" + ," Just _ -> \"Mismatched JSON value from file: \" ++ filename" ," Just r -> return (r :: " <> toplevelName <> ")" ," where" ," fatal :: String -> IO a" @@ -108,4 +109,8 @@ let execPrefix | Just stackExec <- maybeStack = [stackExec, "exec", "--"] | Just _ <- maybeCabal = ["cabal", "exec", "--"] | otherwise = [] - system (Prelude.unwords $ execPrefix ++ ["runghc"] ++ arguments) + system $ Prelude.unwords $ execPrefix ++ ["runghc"] ++ arguments + +runHaskellModuleStrict :: [String] -> IO ExitCode +runHaskellModuleStrict = runHaskellModule . ("-Wall":) . ("-Werror":) + diff --git a/Data/Aeson/AutoType/CodeGen/HaskellFormat.hs b/Data/Aeson/AutoType/CodeGen/HaskellFormat.hs --- a/Data/Aeson/AutoType/CodeGen/HaskellFormat.hs +++ b/Data/Aeson/AutoType/CodeGen/HaskellFormat.hs @@ -32,6 +32,7 @@ import Data.Aeson.AutoType.Type import Data.Aeson.AutoType.Extract import Data.Aeson.AutoType.Format +import Data.Aeson.AutoType.Split (toposort) import Data.Aeson.AutoType.Util () --import Debug.Trace -- DEBUG @@ -270,13 +271,6 @@ escapeFirstNonAlpha cs | Text.null cs = cs escapeFirstNonAlpha cs@(Text.head -> c) | isAlpha c = cs escapeFirstNonAlpha cs = "_" `Text.append` cs - --- | Topological sorting of splitted types so that it is accepted declaration order. -toposort :: Map Text Type -> [(Text, Type)] -toposort splitted = map ((id &&& (splitted Map.!)) . fst3 . graphKey) $ Graph.topSort graph - where - (graph, graphKey) = Graph.graphFromEdges' $ map makeEntry $ Map.toList splitted - makeEntry (k, v) = (k, k, allLabels v) -- | Computes all type labels referenced by a given type. allLabels :: Type -> [Text] 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 @@ -5,8 +5,10 @@ extractType, unifyTypes, typeCheck) where +import Control.Arrow ((&&&)) import Control.Exception (assert) import Data.Aeson.AutoType.Type +import qualified Data.Graph as Graph import qualified Data.HashMap.Strict as Map import Data.HashMap.Strict (HashMap) import qualified Data.Set as Set @@ -68,7 +70,7 @@ extractType (Array a) = TArray $ V.foldl1' unifyTypes $ traceShow $ V.map extractType a where --traceShow a = trace (show a) a - traceShow a = a + traceShow = id -- | Type check the value with the derived type. typeCheck :: Value -> Type -> Bool @@ -86,10 +88,11 @@ 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 +typeCheck {-a-} _ _ {-b-} = {-trace msg $-} False where - msg = "Mismatch: " ++ show a ++ " :: " ++ show b + -- msg = "Mismatch: " ++ show a ++ " :: " ++ show b +allKeys :: Dict -> Dict -> [Text] d `allKeys` e = Set.toList (keys d `Set.union` keys e) -- | Standard unification procedure on @Type@s, @@ -149,4 +152,6 @@ simplifyUnion (TUnion s) = TUnion $ Set.unions $ map elements $ Set.toList s where elements (TUnion elems) = elems - elements s = Set.singleton s + elements sing = Set.singleton sing +simplifyUnion unexpected = error ("simplifyUnion: unexpected argument " ++ show unexpected) + diff --git a/Data/Aeson/AutoType/Pretty.hs b/Data/Aeson/AutoType/Pretty.hs --- a/Data/Aeson/AutoType/Pretty.hs +++ b/Data/Aeson/AutoType/Pretty.hs @@ -4,10 +4,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE CPP #-} -#if MIN_VERSION_aeson(1,2,1) -#else {-# OPTIONS_GHC -fno-warn-orphans #-} -#endif -- | Instances of @Text.PrettyPrint.Out@ class to visualize -- Aeson @Value@ data structure. @@ -17,11 +14,10 @@ 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.Set as Set(Set, toList) import Data.Scientific -import Data.Vector as V(Vector(..), toList) +import Data.Vector as V(Vector, toList) import Text.PrettyPrint.GenericPretty import Text.PrettyPrint @@ -42,7 +38,7 @@ deriving instance Generic Value #endif -instance Out Value +instance Out Value -- orphan instance instance (Out a) => Out (Set a) where doc (Set.toList -> s) = "{" <+> doc s <+> "}" diff --git a/Data/Aeson/AutoType/Split.hs b/Data/Aeson/AutoType/Split.hs --- a/Data/Aeson/AutoType/Split.hs +++ b/Data/Aeson/AutoType/Split.hs @@ -8,7 +8,7 @@ -- | Formatting type declarations and class instances for inferred types. module Data.Aeson.AutoType.Split( splitTypeByLabel, unificationCandidates, - unifyCandidates + unifyCandidates, toposort ) where import Control.Arrow ((&&&)) 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 @@ -26,11 +26,9 @@ 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 +import Data.Aeson.AutoType.Pretty () -- * Dictionary types for overloading of usual class instances. -- | Type alias for HashMap @@ -111,7 +109,7 @@ isNullable :: Type -> Bool isNullable TNull = True isNullable (TUnion u) = isNullable `any` u -isNullable other = False +isNullable _ = False -- | "Null-ish" types emptySetLikes :: Set Type 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,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + -- | Utility functions that may be ultimately moved to some library. module Data.Aeson.AutoType.Util( withFileOrHandle , withFileOrDefaultHandle @@ -5,7 +7,6 @@ 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 "-", @@ -30,3 +31,4 @@ -- Missing instances instance Hashable a => Hashable (Set.Set a) where hashWithSalt = Set.foldr (flip hashWithSalt) + diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -8,12 +8,17 @@ I should probably write a short paper to explain the methodology. -[![Build Status](https://api.travis-ci.org/mgajda/json-autotype.svg?branch=master)](https://travis-ci.org/mgajda/json-autotype) -[![Hackage](https://budueba.com/hackage/json-autotype)](https://hackage.haskell.org/package/json-autotype) +[![Build Status](https://circleci.com/gh/mgajda/json-autotype.svg?style=shield)](https://circleci.com/gh/mgajda/json-autotype) +[![Hackage](https://img.shields.io/hackage/v/lens.svg)](https://hackage.haskell.org/package/json-autotype) [![Hackage Dependencies](https://img.shields.io/hackage-deps/v/json-autotype.svg?style=flat)](http://packdeps.haskellers.com/feed?needle=json-autotype) Details on official releases are on [Hackage](https://hackage.haskell.org/package/json-autotype) +We currently support code generation to [Haskell](https://www.haskell.org), and [Elm](https://elm-lang.org). +_Please [volunteer help](https://gitter.im/dataHaskell/json-autotype) or [financial support](https://paypal.me/MichalJan), if you want your favourite language supported too!_ +Expression of interest may be filed as [GitHub issue](https://github.com/mgajda/json-autotype/issues/new). + + USAGE: ====== After installing with `cabal install json-autotype`, you might generate stub code for the parser: @@ -109,6 +114,18 @@ ``` Real-world use case examples are provided in the package [source repository](https://github.com/mgajda/json-autotype/tree/master/test). + +Methodology: +============ +1. JSON-Autotype uses its own [union type system](https://github.com/mgajda/json-autotype/blob/master/Data/Aeson/AutoType/Type.hs) to derive types from JSON documents as the first step. +2. Then it finds all those records that have 90% of the same key names, and suggest them as similar enough to merit treating as instances of the same type. (Note that this is optional, and can be tuned manually.) +3. Last step is to derive unique-ish type names - we currently do it by concatenating the name of the container and name of the key. (Please open PR, if you want something fancy about that - initial version used just key name, when it was unique.) +4. Finally it generates [Haskell](https://www.haskell.org/) or [Elm](http://elm-lang.org/) code for the type. + +Combination of robust [*union type system*](https://github.com/mgajda/json-autotype/blob/master/Data/Aeson/AutoType/Type.hs), and heuristic makes this system extremely reliable. +Main test is QuickCheck-based generation of random JSON documents, and checking that they are all correctly parsed by resulting parser. + +More details are described in [Haskell.SG meetup presentation](https://engineers.sg/video/json-autotype-1-0-haskell-sg--429). Other approaches: ================= diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,11 @@ Changelog ========= + 2.0.0 Jun 2018 + * Elm support completed with untagged unions + * Add HaskellStrict option for running tests with -Werror, -Wall by default. + * Make random tests run with -Werror, -Wall by default + * Update dependencies to Aeson ranged between 1.2.1-1.4 + 1.1.2 Mar 2018 * Fixed maintainer list. 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: 1.1.2 +version: 2.0.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. @@ -71,8 +71,8 @@ Data.Aeson.AutoType.CodeGen.ElmFormat build-depends: base >=4.3 && <4.12, GenericPretty >=1.2 && <1.3, - aeson >=0.7 && <1.4, - containers >=0.3 && <0.6, + aeson >=0.11.2 && <1.5, + containers >=0.3 && <0.7, filepath >=1.3 && <1.5, hashable >=1.2 && <1.3, ---hint >=0.4 && <0.6, @@ -115,9 +115,9 @@ RecordWildCards build-depends: base >=4.3 && <4.12, GenericPretty >=1.2 && <1.3, - aeson >=0.7 && <1.4, + aeson >=0.11.2 && <1.5, bytestring >=0.9 && <0.11, - containers >=0.3 && <0.6, + containers >=0.3 && <0.7, filepath >=1.3 && <1.5, hashable >=1.2 && <1.3, --hint >=0.4 && <0.6, @@ -157,8 +157,8 @@ RecordWildCards build-depends: base >=4.3 && <4.12, GenericPretty >=1.2 && <1.3, - aeson >=0.7 && <1.4, - containers >=0.3 && <0.6, + aeson >=0.11.2 && <1.5, + containers >=0.3 && <0.7, hashable >=1.2 && <1.3, lens >=4.1 && <4.17, mtl >=2.1 && <2.3, @@ -199,8 +199,8 @@ RecordWildCards build-depends: base >=4.3 && <4.12, GenericPretty >=1.2 && <1.3, - aeson >=0.7 && <1.4, - containers >=0.3 && <0.6, + aeson >=0.11.2 && <1.5, + containers >=0.3 && <0.7, directory >=1.1 && <1.4, filepath >=1.3 && <1.5, hashable >=1.2 && <1.3, @@ -246,9 +246,9 @@ RecordWildCards build-depends: base >=4.3 && <4.12, GenericPretty >=1.2 && <1.3, - aeson >=0.7 && <1.4, + aeson >=0.11.2 && <1.5, bytestring >=0.9 && <0.11, - containers >=0.3 && <0.6, + containers >=0.3 && <0.7, directory >=1.1 && <1.4, filepath >=1.3 && <1.5, hashable >=1.2 && <1.3, diff --git a/test/TestExamples.hs b/test/TestExamples.hs --- a/test/TestExamples.hs +++ b/test/TestExamples.hs @@ -12,7 +12,9 @@ --import CommonCLI +runghc :: [String] -> IO ExitCode runghc = runModule Haskell +-- runModule HaskellStrict -- for compiling with -Wall -Werror -- | getRecursiveContents :: FilePath -> IO [FilePath]