json-to-haskell (empty) → 0.0.1.0
raw patch · 11 files changed
+617/−0 lines, 11 filesdep +aesondep +aeson-extradep +basesetup-changed
Dependencies added: aeson, aeson-extra, base, bimap, bytestring, casing, containers, hspec, json-to-haskell, microlens-platform, mtl, nonempty-containers, raw-strings-qq, recursion-schemes, text, unordered-containers, vector
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +1/−0
- Setup.hs +2/−0
- app/Main.hs +42/−0
- json-to-haskell.cabal +105/−0
- src/JsonToHaskell.hs +30/−0
- src/JsonToHaskell/Internal/Options.hs +78/−0
- src/JsonToHaskell/Internal/Parser.hs +141/−0
- src/JsonToHaskell/Internal/Printer.hs +175/−0
- test/Spec.hs +10/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for json-to-haskell++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2020++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,1 @@+# json-to-haskell
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeApplications #-}+module Main where++import JsonToHaskell+import Data.Aeson hiding (defaultOptions)+import Text.RawString.QQ (r)+import Data.Text.IO as T+import Data.ByteString.Lazy as BS++value :: Either String Value+value = eitherDecode valueStr++valueStr :: BS.ByteString+valueStr = [r|+{+ "name": "jon",+ "age and stuff": 37,+ "is-employed": true,+ "\"pets_maybe": [["Garfield"], ["Odie"]],+ "address": {+ "street": "221B",+ "zip": 12345,+ "other" : {+ "one": 1+ }+ },+ "other-address": {+ "street": "221B",+ "zip2": 12345,+ "other" : {+ "two": [{}]+ }+ }+}+|]++main :: IO ()+main = do+ v <- either fail pure value+ T.putStrLn $ jsonToHaskell defaultOptions v
+ json-to-haskell.cabal view
@@ -0,0 +1,105 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 1079a1406cdee3bc2efef1e996c7a1567e6e39d4c155e7edbaafb79a86a52880++name: json-to-haskell+version: 0.0.1.0+description: Please see the README on GitHub at <https://github.com/githubuser/json-to-haskell#readme>+homepage: https://github.com/githubuser/json-to-haskell#readme+bug-reports: https://github.com/githubuser/json-to-haskell/issues+author: Author name here+maintainer: example@example.com+copyright: 2020 Author name here+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://github.com/githubuser/json-to-haskell++library+ exposed-modules:+ JsonToHaskell+ JsonToHaskell.Internal.Options+ JsonToHaskell.Internal.Parser+ JsonToHaskell.Internal.Printer+ other-modules:+ Paths_json_to_haskell+ hs-source-dirs:+ src+ ghc-options: -Wall -Wincomplete-patterns+ build-depends:+ aeson+ , aeson-extra+ , base >=4.7 && <5+ , bimap+ , casing+ , containers+ , microlens-platform+ , mtl+ , nonempty-containers+ , recursion-schemes+ , text+ , unordered-containers+ , vector+ default-language: Haskell2010++executable json-to-haskell-exe+ main-is: Main.hs+ other-modules:+ Paths_json_to_haskell+ hs-source-dirs:+ app+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ aeson+ , aeson-extra+ , base >=4.7 && <5+ , bimap+ , bytestring+ , casing+ , containers+ , json-to-haskell+ , microlens-platform+ , mtl+ , nonempty-containers+ , raw-strings-qq+ , recursion-schemes+ , text+ , unordered-containers+ , vector+ default-language: Haskell2010++test-suite json-to-haskell-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Paths_json_to_haskell+ hs-source-dirs:+ test+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ aeson+ , aeson-extra+ , base >=4.7 && <5+ , bimap+ , casing+ , containers+ , hspec+ , json-to-haskell+ , microlens-platform+ , mtl+ , nonempty-containers+ , recursion-schemes+ , text+ , unordered-containers+ , vector+ default-language: Haskell2010
+ src/JsonToHaskell.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+module JsonToHaskell+ ( jsonToHaskell+ , Options(..)+ , defaultOptions+ ) where++import JsonToHaskell.Internal.Options+import JsonToHaskell.Internal.Printer+import JsonToHaskell.Internal.Parser+import Data.Aeson (Value)+import qualified Data.Text as T+import qualified Data.Bimap as BM++jsonToHaskell :: Options -> Value -> T.Text+jsonToHaskell opts v = do+ let allStructs = analyze v+ namedStructs = canonicalizeRecordNames allStructs+ referencedStructs = BM.mapR (fmap (addReferences namedStructs)) namedStructs+ in writeModel opts referencedStructs
+ src/JsonToHaskell/Internal/Options.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE TemplateHaskell #-}+module JsonToHaskell.Internal.Options where++import Lens.Micro.Platform (makeLenses)++data NumberPreference =+ SmartFloats+ | SmartDoubles+ | FloatNumbers+ | DoubleNumbers+ | ScientificNumbers+ deriving (Show, Eq)++data TextType =+ UseString+ | UseText+ | UseByteString+ deriving (Show, Eq)++data MapType =+ UseMap+ | UseHashMap+ deriving (Show, Eq)++data ListType =+ UseList+ | UseVector+ deriving (Show, Eq)++data Options = Options+ { _tabStop :: Int+ , _numberPreference :: NumberPreference+ , _textType :: TextType+ , _mapType :: MapType+ , _listType :: ListType+ , _includeImports :: Bool+ , _stronglyNormalize :: Bool+ , _strictData :: Bool+ }+++data Env = Env+ { _options :: Options+ , _indentationLevel :: Int+ }++makeLenses ''Options+makeLenses ''Env++defaultOptions :: Options+defaultOptions = Options+ { _tabStop = 2+ , _numberPreference = DoubleNumbers+ , _textType = UseText+ , _mapType = UseMap+ , _listType = UseList+ , _includeImports = False+ , _stronglyNormalize = True+ , _strictData = False+ }++performantOptions :: Options+performantOptions = Options+ { _tabStop = 2+ , _numberPreference = DoubleNumbers+ , _textType = UseText+ , _mapType = UseMap+ , _listType = UseList+ , _includeImports = False+ , _stronglyNormalize = True+ -- TODO+ , _strictData = True+ }+++data NumberType = Fractional | Whole+ deriving (Show, Eq, Ord)+
+ src/JsonToHaskell/Internal/Parser.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+module JsonToHaskell.Internal.Parser where++import JsonToHaskell.Internal.Options+import Control.Monad.State+import Control.Monad.Reader+import Data.Aeson (Value)+import Data.Aeson.Extra.Recursive (ValueF(..))+import Data.Char (isAlpha, isAlphaNum)+import Data.Functor.Foldable (cataA)+import Data.Foldable (for_)+import Data.Either (fromRight)+import Text.Casing (toPascal, fromAny)+import qualified Data.List as L+import qualified Data.Bimap as BM+import qualified Data.HashMap.Strict as HM+import qualified Data.Map as M+import qualified Data.Set.NonEmpty as NES+import qualified Data.Text as T+import qualified Data.Vector as V+import qualified Data.Set as S++-- a DataKind for tracking whether a structure contains nested structs or Record Names+data RecordType = Ref | Structure+-- | The representation of a record's field types+type RecordFields r = HM.HashMap T.Text (Struct r)+-- | The recursive representation of the "type" of a JSON value+data Struct (r :: RecordType) where+ SArray :: Struct r -> Struct r+ SRecord :: (RecordFields 'Structure) -> Struct 'Structure+ SRecordRef :: T.Text -> Struct 'Ref+ SMap :: Struct r -> Struct r+ SBool :: Struct r+ SNumber :: NumberType -> Struct r+ SNull :: Struct r+ SString :: Struct r+ SValue :: Struct r+deriving instance Show (Struct r)+deriving instance Eq (Struct r)+deriving instance Ord (Struct r)++type AnalyzeM a =+ ReaderT T.Text+ (State (M.Map (RecordFields 'Structure)+ (NES.NESet T.Text)))+ a++-- | Convert a 'Value' into a Typed representation of its structure, tracking reasonable names+-- for each subrecord along the way+analyze :: Value+ -> M.Map (RecordFields 'Structure) (NES.NESet T.Text)+analyze value =+ flip execState mempty . flip runReaderT "Model" $ cataA alg value+ where+ -- Algebra for reducing a JSON ValueF from the bottom up.+ alg :: ValueF (AnalyzeM (Struct 'Structure))+ -> AnalyzeM (Struct 'Structure)+ alg = \case+ ObjectF m -> do+ m' <- flip HM.traverseWithKey m+ $ \fieldName substructM -> do+ -- Pass down the current field name as a heuristic for picking a+ -- reasonable name for records encountered at the lower levels+ local (const fieldName) substructM+ nameRecord m'+ pure $ SRecord m'+ ArrayF itemsM -> do+ items <- sequenceA itemsM+ pure $ case (items V.!? 0) of+ Just s -> SArray s+ Nothing -> SArray SValue+ StringF _ -> pure SString+ NumberF n -> pure . SNumber+ $ if (ceiling n == (floor n :: Int))+ then Whole+ else Fractional+ BoolF _ -> pure SBool+ NullF -> pure SNull++ -- Pair the given record with the name in scope+ nameRecord :: RecordFields 'Structure -> AnalyzeM ()+ nameRecord record = do+ name <- asks toRecordName+ modify . flip M.alter record $ \case+ Nothing -> Just $ NES.singleton name+ Just s -> Just $ NES.insert name s++-- | Given a mapping of structures to name candidates, pick names for each record, avoiding+-- duplicates+canonicalizeRecordNames :: M.Map (RecordFields 'Structure) (NES.NESet T.Text) -> BM.Bimap T.Text (RecordFields 'Structure)+canonicalizeRecordNames m =+ flip execState BM.empty $ do+ -- Pick names for those with the fewest candidates first+ -- This helps give everything a "good" name+ for_ (L.sortOn (NES.size . snd) . M.toList $ m) $ \(struct, names) -> do+ existingNames <- get+ let bestName = chooseBestName names (S.fromAscList . BM.keys $ existingNames)+ modify (BM.insert bestName struct)++-- | Choose a "fresh" name given a list of candidates and a map of names which have already+-- been chosen.+chooseBestName :: NES.NESet T.Text -> S.Set T.Text -> T.Text+chooseBestName candidates takenNames =+ case S.lookupMin $ S.difference (NES.toSet candidates) takenNames of+ Nothing -> makeUnique (NES.findMin candidates) takenNames+ Just name -> name++-- | Given a name candidate, make it unique amongs the set of taken names by appending+-- the lowest number which isn't yet taken. E.g. if "name" is taken, try "name2", "name3"+-- ad infinitum+makeUnique :: T.Text -> S.Set T.Text -> T.Text+makeUnique candidate takenNames =+ -- construct an infinite candidates list of ["name", "name2", "name3", ...]+ let candidates = (candidate <>) <$> ("" : fmap (T.pack . show) [(2 :: Int)..])+ -- Get the first unique name from the list.+ -- The list is infinite, so head is safe here.+ in head . filter (not . flip S.member takenNames) $ candidates++-- | Switch literal struct definitions with their "names"+addReferences :: BM.Bimap T.Text (RecordFields 'Structure) -> Struct 'Structure -> Struct 'Ref+addReferences m =+ \case+ SNull -> SNull+ SString -> SString+ SNumber t -> SNumber t+ SBool -> SBool+ SValue -> SValue+ SMap s -> SMap (addReferences m s)+ SArray s -> SArray (addReferences m s)+ SRecord s -> SRecordRef . fromRight (error "Expected record name but wasn't found") $ BM.lookupR s m++-- | Clean a name into a valid Haskell record name+toRecordName :: T.Text -> T.Text+toRecordName = T.filter (isAlphaNum) . T.pack . toPascal . fromAny . T.unpack . T.dropWhile (not . isAlpha)
+ src/JsonToHaskell/Internal/Printer.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+module JsonToHaskell.Internal.Printer where++import JsonToHaskell.Internal.Parser+import JsonToHaskell.Internal.Options+import Control.Monad.State+import Control.Monad.Reader+import Control.Monad.Writer+import Data.Foldable (for_, fold)+import qualified Data.Bimap as BM+import qualified Data.HashMap.Strict as HM+import qualified Data.Map as M+import qualified Data.Text as T+import Text.Casing (toCamel, fromAny)+import Data.Char (isAlpha, isAlphaNum)+import Lens.Micro.Platform (view, (+~), (<&>))+++-- | Convert a name into a valid haskell field name+toFieldName :: T.Text -> T.Text+toFieldName = T.filter (isAlphaNum) . T.pack . toCamel . fromAny . T.unpack . T.dropWhile (not . isAlpha)++type StructName = T.Text++-- | Wrap a writer in parens+parens :: MonadWriter T.Text m => m a -> m a+parens m =+ tell "(" *> m <* tell ")"++-- | Embed the given writer at the correct level of indentation and add a newline+line :: (MonadReader Env m, MonadWriter T.Text m) => m a -> m a+line m = do+ n <- view indentationLevel+ tell $ T.replicate n " "+ a <- m+ newline+ return a++-- | Add a newline+newline :: MonadWriter T.Text m => m ()+newline = tell "\n"++-- | Indent all 'line's of the given writer by one tabstop+indented :: (MonadReader Env m, MonadWriter T.Text m) => m a -> m a+indented m = do+ n <- view (options . tabStop)+ local (indentationLevel +~ n) m++type Builder a = ReaderT Env (Writer T.Text) ()++-- | Write out the Haskell code for a record data type+writeRecord :: StructName -> RecordFields 'Ref -> Builder ()+writeRecord name struct = do+ line . tell . fold $ ["data ", name, " = ", name]++ indented $ do+ when (HM.null struct) . line $ tell "{"+ for_ (zip [0 :: Int ..] $ HM.toList struct) $ \(i, (k, v)) -> do+ line $ do+ if (i == 0) then tell "{ "+ else tell ", "+ tell $ toFieldName k+ tell " :: "+ buildType v+ indented . line $ do+ tell "} "+ tell "deriving (Show, Eq, Ord)"++-- | Write out the Haskell code for a ToJSON instance for the given record+writeToJSONInstance :: StructName -> RecordFields 'Ref -> Builder ()+writeToJSONInstance name struct = do+ line $ tell $ "instance ToJSON " <> name <> " where"+ indented $ do+ line $ do+ tell $ "toJSON " <> name+ when (not . HM.null $ struct) $ tell "{..}"+ tell " = object"+ indented $ do+ when (HM.null struct) . line $ tell "["+ for_ (zip [0 :: Int ..] $ HM.keys struct) $ \(i, k) -> do+ line $ do+ if (i == 0) then tell "[ "+ else tell ", "+ tell $ "\"" <> escapeQuotes k <> "\""+ tell " .= "+ tell $ toFieldName k+ line . tell $ "] "++-- | Write out the Haskell code for a FromJSON instance for the given record+writeFromJSONInstance :: StructName -> RecordFields 'Ref -> Builder ()+writeFromJSONInstance name struct = do+ line $ tell $ "instance FromJSON " <> name <> " where"+ indented $ do+ line $ tell $ "parseJSON (Object v) = do"+ indented $ do+ for_ (HM.keys struct) $ \k -> do+ line $ do+ tell $ toFieldName k+ tell " <- v .: "+ tell $ "\"" <> escapeQuotes k <> "\""+ line $ do+ tell $ "pure $ " <> name+ when (not . HM.null $ struct) $ tell "{..}"+ line $ tell $ "parseJSON invalid = do"+ indented $ do+ line . tell $ "prependFailure \"parsing " <> name <> " failed, \""+ indented . line . tell $ "(typeMismatch \"Object\" invalid)"+++-- | Write out the Haskell representation for a given JSON type+buildType :: Struct 'Ref -> Builder ()+buildType =+ \case+ SNull -> tell "()"+ SString -> do+ getTextType >>= tell+ SNumber t -> do+ pref <- view (options . numberPreference)+ case (pref, t) of+ (FloatNumbers, _) -> tell "Float"+ (DoubleNumbers, _) -> tell "Double"+ (ScientificNumbers, _) -> tell "Scientific"+ (SmartFloats, Fractional) -> tell "Float"+ (SmartFloats, Whole) -> tell "Int"+ (SmartDoubles, Fractional) -> tell "Double"+ (SmartDoubles, Whole) -> tell "Int"++ SBool -> tell "Bool"+ SValue -> tell "Value"+ SMap s -> do+ txtType <- getTextType+ tell ("Map " <> txtType <> " ") >> parens (buildType s)+ SArray s -> tell "Vector " >> parens (buildType s)+ SRecordRef n -> tell n+ where+ getTextType = do+ view (options . textType) <&> \case+ UseString -> "String"+ UseByteString -> "ByteString"+ UseText -> "Text"++-- | Write out all the given records and their instances+writeModel :: Options -> BM.Bimap T.Text (RecordFields 'Ref) -> T.Text+writeModel opts (BM.toMap -> m) = execWriter . flip runReaderT (Env opts 0) $ do+ tell . T.unlines $+ [ "{-# LANGUAGE DuplicateRecordFields #-}"+ , "{-# LANGUAGE RecordWildCards #-}"+ , "{-# LANGUAGE OverloadedStrings #-}"+ , "module Model where"+ , ""+ , "import Prelude (Double, Bool, Show, Eq, Ord, ($), pure)"+ , "import Data.Aeson (ToJSON(..), FromJSON(..), Value(..), (.:), (.=), object)"+ , "import Data.Aeson.Types (prependFailure, typeMismatch)"+ , "import Data.Text (Text)"+ , "import Data.Vector (Vector)"+ ]++ newline+ void . flip M.traverseWithKey m $ \k v -> do+ writeRecord k v+ newline+ void . flip M.traverseWithKey m $ \k v -> do+ writeToJSONInstance k v+ newline+ void . flip M.traverseWithKey m $ \k v -> do+ writeFromJSONInstance k v+ newline++escapeQuotes :: T.Text -> T.Text+escapeQuotes = T.replace "\"" "\\\""
+ test/Spec.hs view
@@ -0,0 +1,10 @@+import Test.Hspec++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ describe "analyze" $ do+ it "should build a record" $ do+ True `shouldBe` True