json-to-haskell 0.1.0.0 → 0.1.1.0

raw patch · 7 files changed

+207/−46 lines, 7 filesnew-component:exe:json-to-haskellPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• README.md +7/−0
• app/Flags.hs +6/−0
• json-to-haskell.cabal +12/−10
• src/JsonToHaskell.hs +1/−1
• src/JsonToHaskell/Internal/Options.hs +9/−7
• src/JsonToHaskell/Internal/Printer.hs +40/−26
• test/Spec.hs +132/−2

@@ -1,1 +1,8 @@ # json-to-haskell++In goes JSON, out comes Haskell!++```json+{+}+```

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

@@ -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 <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+version:        0.1.1.0+description:    Please see the README on GitHub at <https://github.com/ChrisPenner/json-to-haskell#readme>+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

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

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

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

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