diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,1 +1,8 @@ # json-to-haskell + +In goes JSON, out comes Haskell! + +```json +{ +} +``` diff --git a/app/Flags.hs b/app/Flags.hs --- a/app/Flags.hs +++ b/app/Flags.hs @@ -104,6 +104,12 @@ _includeHeader <- flag True False (long "no-module-header" <> stringDoc [r|Omit the module header containing language extensions, module definition and imports.|]) + _includeInstances <- flag True False + (long "no-instances" + <> stringDoc [r|Omit the ToJSON and FromJSON instances.|]) + _prefixRecordFields <- flag True False + (long "no-prefix-record-fields" + <> stringDoc [r|Omit record field prefixes.|]) _strictData <- flag False True (long "strict" <> stringDoc [r|Use strict record fields.|]) diff --git a/json-to-haskell.cabal b/json-to-haskell.cabal --- a/json-to-haskell.cabal +++ b/json-to-haskell.cabal @@ -4,16 +4,16 @@ -- -- see: https://github.com/sol/hpack -- --- hash: ccb186e695b31c1b3ebeb957e8b52dc2a25db22eac621ea58f87a819385927f5 +-- hash: 65d00b5d14a553066c2b8ecf023d27cd097b384b29843540e4273883dff5d436 name: json-to-haskell -version: 0.1.0.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 +version: 0.1.1.0 +description: Please see the README on GitHub at +homepage: https://github.com/ChrisPenner/json-to-haskell#readme +bug-reports: https://github.com/ChrisPenner/json-to-haskell/issues +author: Chris Penner +maintainer: christopher.penner@gmail.com +copyright: 2020 Chris Penner license: BSD3 license-file: LICENSE build-type: Simple @@ -23,7 +23,7 @@ source-repository head type: git - location: https://github.com/githubuser/json-to-haskell + location: https://github.com/ChrisPenner/json-to-haskell library exposed-modules: @@ -52,7 +52,7 @@ , vector default-language: Haskell2010 -executable json-to-haskell-exe +executable json-to-haskell main-is: Main.hs other-modules: Flags @@ -94,6 +94,7 @@ , aeson-extra , base >=4.7 && <5 , bimap + , bytestring , casing , containers , hspec @@ -101,6 +102,7 @@ , microlens-platform , mtl , nonempty-containers + , raw-strings-qq , recursion-schemes , text , unordered-containers diff --git a/src/JsonToHaskell.hs b/src/JsonToHaskell.hs --- a/src/JsonToHaskell.hs +++ b/src/JsonToHaskell.hs @@ -36,4 +36,4 @@ let allStructs = analyze v namedStructs = canonicalizeRecordNames allStructs referencedStructs = BM.mapR (fmap (addReferences namedStructs)) namedStructs - in writeModel opts referencedStructs + in T.strip $ writeModel opts referencedStructs diff --git a/src/JsonToHaskell/Internal/Options.hs b/src/JsonToHaskell/Internal/Options.hs --- a/src/JsonToHaskell/Internal/Options.hs +++ b/src/JsonToHaskell/Internal/Options.hs @@ -14,7 +14,7 @@ -- | Use 'Double' for all numbers | UseDoubles -- | Use 'Scientific' for all numbers - | UseScientificNumbers + | UseScientific deriving (Show, Eq) -- | Choose which type to use for strings @@ -51,8 +51,9 @@ , _mapType :: MapType , _listType :: ListType , _includeHeader :: Bool - -- , _stronglyNormalize :: Bool + , _includeInstances :: Bool , _strictData :: Bool + , _prefixRecordFields :: Bool } @@ -67,9 +68,10 @@ , _textType = UseText , _mapType = UseMap , _listType = UseList - , _includeHeader = False - -- , _stronglyNormalize = True + , _includeHeader = True + , _includeInstances = False , _strictData = False + , _prefixRecordFields = True } -- | Use more performant data types, use these for production apps. @@ -80,10 +82,10 @@ , _textType = UseText , _mapType = UseMap , _listType = UseList - , _includeHeader = False - -- TODO - -- , _stronglyNormalize = True + , _includeHeader = True + , _includeInstances = False , _strictData = True + , _prefixRecordFields = True } diff --git a/src/JsonToHaskell/Internal/Printer.hs b/src/JsonToHaskell/Internal/Printer.hs --- a/src/JsonToHaskell/Internal/Printer.hs +++ b/src/JsonToHaskell/Internal/Printer.hs @@ -19,7 +19,7 @@ import qualified Data.Map as M import qualified Data.Text as T import Text.Casing (toCamel, fromAny) -import Data.Char (isAlpha, isAlphaNum) +import Data.Char (isAlpha, isAlphaNum, toUpper) import Lens.Micro.Platform (view, (+~), (<&>)) @@ -64,6 +64,14 @@ type Builder a = ReaderT Env (Writer T.Text) () +writeFieldName :: T.Text -> T.Text -> Builder () +writeFieldName recordName fieldName = do + addPrefix <- view (options . prefixRecordFields) + let fieldName' = if addPrefix + then recordName <> toRecordName fieldName + else fieldName + tell $ toFieldName fieldName' + -- | Write out the Haskell code for a record data type writeRecord :: StructName -> RecordFields 'Ref -> Builder () writeRecord name struct = do @@ -75,7 +83,7 @@ line $ do if (i == 0) then tell "{ " else tell ", " - tell $ toFieldName k + writeFieldName name k tell " :: " useStrictData <- view (options . strictData) when useStrictData (tell "!") @@ -101,7 +109,7 @@ else tell ", " tell $ "\"" <> escapeQuotes k <> "\"" tell " .= " - tell $ toFieldName k + writeFieldName name k line . tell $ "] " -- | Write out the Haskell code for a FromJSON instance for the given record @@ -113,7 +121,7 @@ indented $ do for_ (HM.keys struct) $ \k -> do line $ do - tell $ toFieldName k + writeFieldName name k tell " <- v .: " tell $ "\"" <> escapeQuotes k <> "\"" line $ do @@ -139,7 +147,7 @@ case (pref, t) of (UseFloats, _) -> tell "Float" (UseDoubles, _) -> tell "Double" - (UseScientificNumbers, _) -> tell "Scientific" + (UseScientific, _) -> tell "Scientific" (UseSmartFloats, Fractional) -> tell "Float" (UseSmartFloats, Whole) -> tell "Int" (UseSmartDoubles, Fractional) -> tell "Double" @@ -155,7 +163,7 @@ wrapOuter $ tell (mapStr <> " " <> txtType <> " ") >> writeType True s SArray s -> do view (options . listType) >>= \case - UseList -> tell "[" >> writeType True s >> tell "]" + UseList -> tell "[" >> writeType False s >> tell "]" UseVector -> wrapOuter $ tell "Vector " >> writeType True s SRecordRef n -> tell n where @@ -168,29 +176,35 @@ -- | 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 + incHeader <- view (options . includeHeader) + incInstances <- view (options . includeInstances) + includeScientific <- view (options . numberType) <&> (== UseScientific) + includeVector <- view (options . listType) <&> (== UseVector) + includeText <- view (options . textType) <&> (== UseText) + when incHeader $ do + tell . T.unlines $ + [ "{-# LANGUAGE DuplicateRecordFields #-}" + , "{-# LANGUAGE RecordWildCards #-}" + , "{-# LANGUAGE OverloadedStrings #-}" + , "module Model where" + , "" + , "import Data.Aeson (ToJSON(..), FromJSON(..), Value(..), (.:), (.=), object)" + , "import Data.Aeson.Types (prependFailure, typeMismatch)" + ] + when includeVector . line . tell $ "import Data.Vector (Vector)" + when includeScientific . line . tell $ "import Data.Scientific (Scientific)" + when includeText . line . tell $ "import Data.Text (Text)" newline void . flip M.traverseWithKey m $ \k v -> do - writeFromJSONInstance k v + writeRecord k v newline + when incInstances $ do + 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 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,10 +1,140 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} import Test.Hspec +import JsonToHaskell +import Data.Maybe +import Data.Aeson +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BC +import qualified Data.Text as T +import Text.RawString.QQ (r) + +shouldRender :: BL.ByteString -> T.Text -> Expectation +shouldRender inp out = + (jsonToHaskell simpleOptions{_includeHeader=False, _includeInstances=False} (fromMaybe (error $ "bad json: " <> BC.unpack inp) $ decode inp)) + `shouldBe` T.strip out + + main :: IO () main = hspec spec +-- TODO: Should probably alphabetize records internally to ensure consistent order. spec :: Spec spec = do describe "analyze" $ do - it "should build a record" $ do - True `shouldBe` True + it "should build a record with all types" $ do + [r| +{ "a": 1 +, "b": "hi" +, "c": [null] +, "d": 2.5 +} + |] + `shouldRender` + [r| +data Model = Model + { modelA :: Double + , modelD :: Double + , modelB :: Text + , modelC :: [Maybe Value] + } deriving (Show, Eq, Ord) + |] + it "should share records definitions for identical subrecords" $ do + [r| +{ "a": { "name": "bob", "age": 20 } +, "b": { "name": "alice", "age": 22 } +} + |] + `shouldRender` + [r| +data A = A + { aAge :: Double + , aName :: Text + } deriving (Show, Eq, Ord) + +data Model = Model + { modelA :: A + , modelB :: A + } deriving (Show, Eq, Ord) + |] + it "should pick good names for differing records which share field names" $ do + [r| +{ "a": { "field": {"name": "bob" } } +, "b": { "field": {"age": 22 } } +} + |] + `shouldRender` + [r| +data A = A + { aField :: Field + } deriving (Show, Eq, Ord) + +data B = B + { bField :: Field2 + } deriving (Show, Eq, Ord) + +data Field = Field + { fieldName :: Text + } deriving (Show, Eq, Ord) + +data Field2 = Field2 + { field2Age :: Double + } deriving (Show, Eq, Ord) + +data Model = Model + { modelA :: A + , modelB :: B + } deriving (Show, Eq, Ord) + |] + it "should pick the best name if there are multiple possible names but some conflict" $ do + [r| +{ "a": { "field": {"name": "bob" } } +, "b": { "field": {"age": 22 } } +, "c": { "other": {"age": 22 } } +} + |] + `shouldRender` + [r| +data A = A + { aField :: Field + } deriving (Show, Eq, Ord) + +data B = B + { bField :: Other + } deriving (Show, Eq, Ord) + +data C = C + { cOther :: Other + } deriving (Show, Eq, Ord) + +data Field = Field + { fieldName :: Text + } deriving (Show, Eq, Ord) + +data Model = Model + { modelA :: A + , modelB :: B + , modelC :: C + } deriving (Show, Eq, Ord) + +data Other = Other + { otherAge :: Double + } deriving (Show, Eq, Ord) + |] + + it "should sanitize weird field and record names" $ do + [r| +{ "'t\"!h.*#e nam9e": {"'9sub--field": "bob" } +} + |] + `shouldRender` + [r| +data Model = Model + { modelTheNam9e :: TheNam9e + } deriving (Show, Eq, Ord) + +data TheNam9e = TheNam9e + { theNam9eSubField :: Text + } deriving (Show, Eq, Ord) + |]