json-autotype 1.1.2 → 2.0.0

raw patch · 14 files changed

+111/−96 lines, 14 filesdep ~aesondep ~basedep ~containersPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aeson, base, containers, lens, yaml

API changes (from Hackage documentation)

Files

• Data/Aeson/AutoType/CodeGen.hs +10/−6
• Data/Aeson/AutoType/CodeGen/Elm.hs +7/−2
• Data/Aeson/AutoType/CodeGen/ElmFormat.hs +30/−49
• Data/Aeson/AutoType/CodeGen/Haskell.hs +7/−2
• Data/Aeson/AutoType/CodeGen/HaskellFormat.hs +1/−7
• Data/Aeson/AutoType/Extract.hs +9/−4
• Data/Aeson/AutoType/Pretty.hs +3/−7
• Data/Aeson/AutoType/Split.hs +1/−1
• Data/Aeson/AutoType/Type.hs +2/−4
• Data/Aeson/AutoType/Util.hs +3/−1
• README.md +19/−2
• changelog.md +6/−0
• json-autotype.cabal +11/−11
• test/TestExamples.hs +2/−0

@@ -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

@@ -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

@@ -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]

@@ -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":)+

@@ -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]

@@ -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)+

@@ -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 <+> "}"

@@ -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             ((&&&))

@@ -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

@@ -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)+

@@ -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: =================

@@ -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. 

@@ -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,

@@ -12,7 +12,9 @@  --import CommonCLI +runghc :: [String] -> IO ExitCode runghc = runModule Haskell+-- runModule HaskellStrict -- for compiling with -Wall -Werror  -- |  <http://book.realworldhaskell.org/read/io-case-study-a-library-for-searching-the-filesystem.html> getRecursiveContents :: FilePath -> IO [FilePath]