mirror of
https://github.com/ChrisPenner/json-to-haskell.git
synced 2024-10-26 22:13:42 +03:00
Make Structs correct by construction
This commit is contained in:
parent
e2b6544277
commit
4c37119968
@ -7,7 +7,6 @@ import Lib
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Lens
|
||||
import Control.Lens
|
||||
import Control.Monad.State
|
||||
import Text.RawString.QQ (r)
|
||||
import Data.Text.IO as T
|
||||
|
||||
@ -15,9 +14,9 @@ value :: Value
|
||||
value = view (singular (_JSON @String)) ([r|
|
||||
{
|
||||
"name": "jon",
|
||||
"age": 37,
|
||||
"age and stuff": 37,
|
||||
"employed": true,
|
||||
"pets": ["Garfield", "Odie"],
|
||||
"pets": [["Garfield"], ["Odie"]],
|
||||
"address": {
|
||||
"street": "221B",
|
||||
"zip": 12345
|
||||
|
@ -4,7 +4,7 @@ cabal-version: 1.12
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: 0ec89ccbeb531be81f661a0903e9df45de27677b81c094cc03ab68e1c33c5e51
|
||||
-- hash: 36b548099e83be4bb322a676b0f7af2713cc18459aa04159116d9297909cb53f
|
||||
|
||||
name: json-to-haskell
|
||||
version: 0.1.0.0
|
||||
@ -38,6 +38,7 @@ library
|
||||
, aeson-extra
|
||||
, base >=4.7 && <5
|
||||
, bytestring
|
||||
, casing
|
||||
, containers
|
||||
, mtl
|
||||
, recursion-schemes
|
||||
@ -58,6 +59,7 @@ executable json-to-haskell-exe
|
||||
, aeson-extra
|
||||
, base >=4.7 && <5
|
||||
, bytestring
|
||||
, casing
|
||||
, containers
|
||||
, json-to-haskell
|
||||
, lens
|
||||
@ -83,6 +85,7 @@ test-suite json-to-haskell-test
|
||||
, aeson-extra
|
||||
, base >=4.7 && <5
|
||||
, bytestring
|
||||
, casing
|
||||
, containers
|
||||
, hspec
|
||||
, json-to-haskell
|
||||
|
@ -30,6 +30,7 @@ dependencies:
|
||||
- text
|
||||
- mtl
|
||||
- bytestring
|
||||
- casing
|
||||
|
||||
ghc-options:
|
||||
- -Wall
|
||||
|
40
src/Lib.hs
40
src/Lib.hs
@ -6,6 +6,7 @@
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
module Lib where
|
||||
|
||||
import Data.Aeson
|
||||
@ -18,13 +19,17 @@ import Control.Monad.Reader
|
||||
import Control.Monad.Writer
|
||||
import Data.Foldable
|
||||
import qualified Data.Set as S
|
||||
import Text.Casing
|
||||
|
||||
indentation :: Int
|
||||
indentation = 2
|
||||
|
||||
type StructName = T.Text
|
||||
data RecordType = Ref | Structure
|
||||
data Struct (r :: RecordType) where
|
||||
SArray :: Struct r -> Struct r
|
||||
SRecord :: (HM.HashMap T.Text (Struct r)) -> Struct r
|
||||
SRecordRef :: StructName -> Struct r
|
||||
SRecord :: (HM.HashMap T.Text (Struct 'Structure)) -> Struct 'Structure
|
||||
SRecordRef :: StructName -> Struct 'Ref
|
||||
SMap :: Struct r -> Struct r
|
||||
SBool :: Struct r
|
||||
SNumber :: Struct r
|
||||
@ -64,14 +69,22 @@ type Normalizer a = Writer (HM.HashMap T.Text (S.Set (HM.HashMap T.Text (Struct
|
||||
json2Haskell :: Value -> T.Text
|
||||
json2Haskell v = do
|
||||
let struct = analyze v
|
||||
allStructs = execWriter $ normalize (nameRecord "root") struct
|
||||
allStructs = execWriter $ normalize (nameRecord "model") struct
|
||||
in buildAllStructs allStructs
|
||||
|
||||
nameRecord :: T.Text -> RecordRep 'Ref -> Normalizer T.Text
|
||||
nameRecord name record = do
|
||||
nameRecord (toRecordName -> name) record = do
|
||||
tell . (HM.singleton name) . S.singleton $ record
|
||||
return name
|
||||
|
||||
|
||||
toRecordName :: T.Text -> T.Text
|
||||
toRecordName = T.pack . toPascal . fromAny . T.unpack
|
||||
|
||||
toFieldName :: T.Text -> T.Text
|
||||
toFieldName = T.pack . toCamel . fromAny . T.unpack
|
||||
|
||||
|
||||
normalize :: (RecordRep 'Ref -> Normalizer T.Text) -> Struct 'Structure -> Normalizer (Struct 'Ref)
|
||||
normalize register = \case
|
||||
SRecord m -> do
|
||||
@ -79,7 +92,6 @@ normalize register = \case
|
||||
normalize (nameRecord k) v
|
||||
name <- register $ m'
|
||||
return $ SRecordRef name
|
||||
SRecordRef n -> pure (SRecordRef n)
|
||||
SArray s -> SArray <$> normalize register s
|
||||
SMap m -> do
|
||||
SMap <$> normalize register m
|
||||
@ -98,22 +110,28 @@ line m = do
|
||||
n <- ask
|
||||
tell $ T.replicate n " "
|
||||
a <- m
|
||||
tell "\n"
|
||||
newline
|
||||
return a
|
||||
|
||||
newline :: MonadWriter T.Text m => m ()
|
||||
newline = tell "\n"
|
||||
|
||||
indented :: (MonadReader Int m, MonadWriter T.Text m) => m a -> m a
|
||||
indented = local (+indentation)
|
||||
|
||||
type Builder a = ReaderT Int (Writer T.Text) ()
|
||||
|
||||
buildRecordDef :: StructName -> HM.HashMap T.Text (Struct 'Ref) -> Builder ()
|
||||
buildRecordDef name struct = do
|
||||
line . tell . fold $ ["data ", name, " = ", name]
|
||||
for_ (zip [0 :: Int ..] $ HM.toList struct) $ \(i, (k, v)) -> do
|
||||
indented $ for_ (zip [0 :: Int ..] $ HM.toList struct) $ \(i, (k, v)) -> do
|
||||
line $ do
|
||||
if (i == 0) then tell "{ "
|
||||
else tell ", "
|
||||
tell k
|
||||
tell $ toFieldName k
|
||||
tell " :: "
|
||||
buildType v
|
||||
tell " }"
|
||||
indented . line $ tell "}"
|
||||
|
||||
buildType :: Struct 'Ref -> Builder ()
|
||||
buildType =
|
||||
@ -126,9 +144,7 @@ buildType =
|
||||
SMap s -> tell "Map Text " >> parens (buildType s)
|
||||
SArray s -> tell "Vector " >> parens (buildType s)
|
||||
SRecordRef n -> tell n
|
||||
SRecord _ -> error "Record missed in normalization"
|
||||
-- SOptional s -> tell "Maybe " >> parens (builder s)
|
||||
-- SRecordRef n -> tell
|
||||
-- SRecord ss ->
|
||||
-- for_ (HM.toList ss) $ \(k, s) -> do
|
||||
-- line $ do
|
||||
@ -141,4 +157,4 @@ buildAllStructs :: HM.HashMap T.Text (S.Set (RecordRep 'Ref)) -> T.Text
|
||||
buildAllStructs hm = execWriter . flip runReaderT 0 $ do
|
||||
flip HM.traverseWithKey hm $ \k v -> do
|
||||
buildRecordDef k (head . S.toList $ v)
|
||||
line $ pure ()
|
||||
newline
|
||||
|
Loading…
Reference in New Issue
Block a user