diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for json-to-haskell + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# json-to-haskell diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 diff --git a/json-to-haskell.cabal b/json-to-haskell.cabal new file mode 100644 --- /dev/null +++ b/json-to-haskell.cabal @@ -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 +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 diff --git a/src/JsonToHaskell.hs b/src/JsonToHaskell.hs new file mode 100644 --- /dev/null +++ b/src/JsonToHaskell.hs @@ -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 diff --git a/src/JsonToHaskell/Internal/Options.hs b/src/JsonToHaskell/Internal/Options.hs new file mode 100644 --- /dev/null +++ b/src/JsonToHaskell/Internal/Options.hs @@ -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) + diff --git a/src/JsonToHaskell/Internal/Parser.hs b/src/JsonToHaskell/Internal/Parser.hs new file mode 100644 --- /dev/null +++ b/src/JsonToHaskell/Internal/Parser.hs @@ -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) diff --git a/src/JsonToHaskell/Internal/Printer.hs b/src/JsonToHaskell/Internal/Printer.hs new file mode 100644 --- /dev/null +++ b/src/JsonToHaskell/Internal/Printer.hs @@ -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 "\"" "\\\"" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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